## This makefile builds the Cv utility.#Cv.c.o ƒ Cv.c C cv.cCv ƒ Cv.c.o Link Cv.c.o ∂ "{CLibraries}"CInterface.o ∂ "{CLibraries}"StdCLib.o ∂ "{CLibraries}"CSANELib.o ∂ "{CLibraries}"CRuntime.o ∂ -c "MPS " -t "MPST" ∂ -o {Commands}Cv :MPW:MPW Tools:Tools with Source:Detab ƒ:Detab.c
/*------------------------------------------------------------------------------NAME Detab -- replace tabs with spaces while maintaining the column alignments SYNOPSIS Detab [-c tab_length] [file…] DESCRIPTION "Detab" filters the tabs in a text file using a tab count of n columns. All the tab characters are replaced by spaces to fill to the appropriate column, rather than simply replacing each tab with n spaces. If no files are specified standard input is read. Output is written to the standard output. DATE Friday, 22 July 1988 COPYRIGHT Copyright W Simon Tortike 1988 Department of Mining, Metallurgical and Petroleum Engineering University of Alberta Edmonton Alberta Canada T6G 2G6 Tel. 403/432-3337 Bitnet: stortike@ualtavm UUCP: simon@alberta With help from portions of the Count.c example in MPW, Apple Computer, Inc. 1985-1987. All rights reserved. ------------------------------------------------------------------------------*/#include <types.h>#include <stdio.h>#include <ErrMgr.h>#include <Errors.h>#include <CursorCtl.h>#include <CType.h>/* Variables local to this file */#define FBUFSIZ 8*BUFSIZ#define MYTAB 3static char *usage = "# Usage - %s [-c tab_length] [files…].\n";static Boolean optionsSpecified; /* Use optionsSpecified to separate all from one option only */static Boolean colOption;static char errorBuffer[256]; /* space to store text from GetSysErrText */static char filebuffer[FBUFSIZ]; /* buffer used for I/O */main(argc, argv) int argc; char *argv[];{ FILE *input; int atoi();/* int isdigit(); This is a macro definition, not a function. */ long status; long result; int tab; long i; long files; long parms; long length; long optparm, colparm; /* optparm makes sense when there is more than one option taking */ /* a parameter. */ files = status = optparm = colparm = 0; optionsSpecified = colOption = false; InitCursorCtl(NULL); tab = MYTAB; /* default */ for (parms = 1; parms < argc; parms++) { length = strlen(argv[parms]); if (*argv[parms] != '-') { if (parms > optparm) /* it must be a file */ argv[++files] = argv[parms]; } else if (tolower(*(argv[parms]+1)) == 'c' && length ==2) { optionsSpecified = colOption = true; optparm = colparm = parms + 1; /* column parameter follows option "-c" */ for (i=0; *(argv[colparm]+i); i++) /* Make sure we have only digits */ { if ( ! isdigit(*(argv[colparm]+i))) { fprintf(stderr,"### %s - %s \"%s\" is not a number.\n", argv[0], argv[parms], argv[colparm]); fprintf(stderr, usage, argv[0]); return 1; } } tab = atoi(argv[colparm]); /* everything is OK */ } else { fprintf(stderr,"### %s - \"%s\" is not an option.\n", argv[0], argv[parms]); fprintf(stderr, usage, argv[0]); return 1; } } if (files == 0) { result = filter (stdin, tab); fprintf(stderr,"### %d tabs processed at %d columns each from standard input.\n", result, tab); } else for (parms = 1; parms <= files; parms++) { if ((input = fopen (argv[parms], "r")) != NULL) { /* By specifying a larger buffer than the standard buffer allocated by fopen, performance can be improved two or three times. */ setvbuf(input, filebuffer, _IOFBF, FBUFSIZ); result = filter (input, tab); fprintf(stderr,"### %d tabs processed at %d columns each from %s.\n", result, tab, argv[parms]); fclose (input); } else { fprintf(stderr,"### %s - Unable to open file %s.\n", argv[0], argv[parms]); fprintf(stderr,"# %s\n", GetSysErrText(MacOSErr, errorBuffer)); status = 2; } } return status;}long filter (input, tab) FILE *input; int tab;{ char c; int ncol, i; long ntabs; ncol = ntabs = 0; while ( (c=getc(input)) != EOF) switch (c) { case '\t': ntabs++; do { ++ncol; putchar(' '); } while (ncol % tab); break; case '\n': putchar(c); ncol = 0; SpinCursor(2); break; default: ++ncol; putchar(c); break; } fflush (stdout); return ntabs;} :MPW:MPW Tools:Tools with Source:Detab ƒ:Detab.make
/* Detab.r - commando resource file Copyright W Simon Tortike 1988 Department of Mining, Metallurgical and Petroleum Engineering University of Alberta Edmonton Alberta Canada T6G 2G6 Tel. 403/432-3337 Bitnet: stortike@ualtavm UUCP: simon@alberta With help from portions of the Count.r example in MPW, Apple Computer, Inc. 1985-1987. All rights reserved. Detab [-c tab_length] [file…] < file > out Detab [-c tab_length] § | catenate > § :scans, converts and replaces target selection*/#include "Cmdo.r"#include "Types.r"type 'MPST' as 'STR ';resource 'MPST' (0) { "Detab - Version 1.0"};resource 'cmdo' (128) { { 245, /* Height of dialog */ "Replaces the tabs in its input, and writes the results to standard output. " "\"Detab [-c tab_length] § | catenate > §\" scans, converts and replaces the target " "selection.", { notDependent {}, RegularEntry { "Enter the tab_length:", {25, 250, 45, 410}, {50, 350, 66, 400}, "3", ignoreCase, "-c", "Replace all tabs with spaces using tab_length columns as the base. " "The default is 3.", }, notDependent {}, TextBox { gray, {17, 240, 75, 450}, "Detab" }, Or {{-4}}, MultiFiles { "Files to filter…", "Select the files to filter. If no files are specified Detab reads " "from standard input.", {36, 35, 56, 200}, "Files to filter:", "", MultiInputFiles { {TEXT}, FilterTypes, "Only text files", "All files", } }, Or {{-3}}, Redirection { StandardInput, {85, 30} }, notDependent {}, Redirection { StandardOutput, {85, 180} }, notDependent {}, Redirection { DiagnosticOutput, {85, 330} }, notDependent {}, TextBox { gray, {80, 25, 125, 450}, "Redirection" }, notDependent {}, VersionDialog { VersionResource { 'MPST', 0 }, "by W.S. Tortike, Department of Mining, Metallurgical and Petroleum " "Engineering, The University of Alberta, Edmonton, AB, CANADA T6G 2G6.", noDialog } } }}; :MPW:MPW Tools:Tools with Source:Detab ƒ:Install_Detab_Help
/* alloca -- (mostly) portable public-domain implementation -- D A Gwyn This implementation of the PWB library alloca() function, which is used to allocate space off the run-time stack so that it is automatically reclaimed upon procedure exit, was inspired by discussions with J. Q. Johnson of Cornell. It should work under any C implementation that uses an actual procedure stack (as opposed to a linked list of frames). There are some preprocessor constants that can be defined when compiling for your specific system, for improved efficiency; however, the defaults should be okay. The general concept of this implementation is to keep track of all alloca()-allocated blocks, and reclaim any that are found to be deeper in the stack than the current invocation. This heuristic does not reclaim storage as soon as it becomes invalid, but it will do so eventually. As a special case, alloca(0) reclaims storage without allocating any. It is a good idea to use alloca(0) in your main control loop, etc. to force garbage collection.*/#ifndef lintstatic char SCCSid[] = "@(#)alloca.c 1.1"; /* for the "what" utility */#endif#ifdef emacs#include "config.h"#ifdef static/* actually, only want this if static is defined as "" -- this is for usg, in which emacs must undefine static in order to make unexec workable */#ifndef STACK_DIRECTIONyoulose-- must know STACK_DIRECTION at compile-time#endif /* STACK_DIRECTION undefined */#endif static#endif emacs#ifdef X3J11typedef void *pointer; /* generic point*/#elsetypedef char *pointer; /* generic pointer type */#endif#define NULL 0 /* null pointer constant */extern void free();extern pointer malloc();/* Define STACK_DIRECTION if you know the direction of stack growth for your system; otherwise it will be automatically deduced at run-time. STACK_DIRECTION > 0 => grows toward higher addresses STACK_DIRECTION < 0 => grows toward lower addresses STACK_DIRECTION = 0 => direction of growth unknown*/#ifndef STACK_DIRECTION#define STACK_DIRECTION 0 /* direction unknown */#endif#if STACK_DIRECTION != 0#define STACK_DIR STACK_DIRECTION /* known at compile-time */#else /* STACK_DIRECTION == 0; need run-time code */static int stack_dir; /* 1 or -1 once known */#define STACK_DIR stack_dirstatic voidfind_stack_direction (/* void */){ static char *addr = NULL; /* address of first `dummy', once known */ auto char dummy; /* to get stack address */ if (addr == NULL) { /* initial entry */ addr = &dummy; find_stack_direction (); /* recurse once */ } else /* second entry */ if (&dummy > addr) stack_dir = 1; /* stack grew upward */ else stack_dir = -1; /* stack grew downward */}#endif /* STACK_DIRECTION == 0 *//* An "alloca header" is used to: (a) chain together all alloca()ed blocks; (b) keep track of stack depth. It is very important that sizeof(header) agree with malloc() alignment chunk size. The following default should work okay.*/#ifndef ALIGN_SIZE#define ALIGN_SIZE sizeof(double)#endiftypedef union hdr{ char align[ALIGN_SIZE]; /* to force sizeof(header) */ struct { union hdr *next; /* for chaining headers */ char *deep; /* for stack depth measure */ } h;} header;/* alloca( size ) returns a pointer to at least `size' bytes of storage which will be automatically reclaimed upon exit from the procedure that called alloca(). Originally, this space was supposed to be taken from the current stack frame of the caller, but that method cannot be made to work for some implementations of C, for example under Gould's UTX/32.*/static header *last_alloca_header = NULL; /* -> last alloca header */pointeralloca (size) /* returns pointer to storage */ unsigned size; /* # bytes to allocate */{ auto char probe; /* probes stack depth: */ register char *depth = &probe;#if STACK_DIRECTION == 0 if (STACK_DIR == 0) /* unknown growth direction */ find_stack_direction ();#endif /* Reclaim garbage, defined as all alloca()ed storage that was allocated from deeper in the stack than currently. */ { register header *hp; /* traverses linked list */ for (hp = last_alloca_header; hp != NULL;) if (STACK_DIR > 0 && hp->h.deep > depth || STACK_DIR < 0 && hp->h.deep < depth) { register header *np = hp->h.next; free ((pointer) hp); /* collect garbage */ hp = np; /* -> next header */ } else break; /* rest are not deeper */ last_alloca_header = hp; /* -> last valid storage */ } if (size == 0) return NULL; /* no allocation required */ /* Allocate combined header + user data storage. */ { register pointer new = malloc (sizeof (header) + size); /* address of header */ ((header *)new)->h.next = last_alloca_header; ((header *)new)->h.deep = depth; last_alloca_header = (header *)new; /* User storage begins just after header. */ return (pointer)((char *)new + sizeof(header)); }} :MPW:MPW Tools:Tools with Source:e?grep ƒ:dfa.c
/* dfa.c - determinisitic extended regexp routines for GNU Copyright (C) 1988 Free Software Foundation, Inc. Written June, 1988 by Mike Haertel Modified July, 1988 by Arthur David Olson to assist BMG speedups NO WARRANTY BECAUSE THIS PROGRAM IS LICENSED FREE OF CHARGE, WE PROVIDE ABSOLUTELYNO WARRANTY, TO THE EXTENT PERMITTED BY APPLICABLE STATE LAW. EXCEPTWHEN OTHERWISE STATED IN WRITING, FREE SOFTWARE FOUNDATION, INC,RICHARD M. STALLMAN AND/OR OTHER PARTIES PROVIDE THIS PROGRAM "AS IS"WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING,BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY ANDFITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITYAND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVEDEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR ORCORRECTION. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW WILL RICHARD M.STALLMAN, THE FREE SOFTWARE FOUNDATION, INC., AND/OR ANY OTHER PARTYWHO MAY MODIFY AND REDISTRIBUTE THIS PROGRAM AS PERMITTED BELOW, BELIABLE TO YOU FOR DAMAGES, INCLUDING ANY LOST PROFITS, LOST MONIES, OROTHER SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THEUSE OR INABILITY TO USE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA ORDATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY THIRD PARTIES ORA FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS) THISPROGRAM, EVEN IF YOU HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCHDAMAGES, OR FOR ANY CLAIM BY ANY OTHER PARTY. GENERAL PUBLIC LICENSE TO COPY 1. You may copy and distribute verbatim copies of this source fileas you receive it, in any medium, provided that you conspicuously andappropriately publish on each copy a valid copyright notice "Copyright (C) 1988 Free Software Foundation, Inc."; and include following thecopyright notice a verbatim copy of the above disclaimer of warrantyand of this License. You may charge a distribution fee for thephysical act of transferring a copy. 2. You may modify your copy or copies of this source file orany portion of it, and copy and distribute such modifications underthe terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains or is a derivative of this program or any part thereof, to be licensed at no charge to all third parties on terms identical to those contained in this License Agreement (except that you may choose to grant more extensive warranty protection to some or all third parties, at your option). c) You may charge a distribution fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee.Mere aggregation of another unrelated program with this program (or itsderivative) on a volume of a storage or distribution medium does not bringthe other program under the scope of these terms. 3. You may copy and distribute this program or any portion of it incompiled, executable or object code form under the terms of Paragraphs1 and 2 above provided that you do the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal shipping charge) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.)For an executable file, complete source code means all the source code forall modules it contains; but, as a special exception, it need not includesource code for modules which are standard libraries that accompany theoperating system on which the executable file runs. 4. You may not copy, sublicense, distribute or transfer this programexcept as expressly provided under this License Agreement. Any attemptotherwise to copy, sublicense, distribute or transfer this program is void andyour rights to use the program under this License agreement shall beautomatically terminated. However, parties who have received computersoftware programs from you with this License Agreement will not havetheir licenses terminated so long as such parties remain in full compliance. 5. If you wish to incorporate parts of this program into other freeprograms whose distribution conditions are different, write to the FreeSoftware Foundation at 675 Mass Ave, Cambridge, MA 02139. We have not yetworked out a simple rule that can be stated here, but we will often permitthis. We will be guided by the two goals of preserving the free status ofall derivatives our free software and of promoting the sharing and reuse ofsoftware.In other words, you are welcome to use, share and improve this program.You are forbidden to forbid anyone else to use, share and improvewhat you give them. Help stamp out software-hoarding! *//* Prominent notice: This file modified 2/89 for MPW compatibility by Scott Lindsey, <scott@claris.com> */ #include <ctype.h>#include "dfa.h"#ifdef __STDC__typedef void *ptr_t;#elsetypedef char *ptr_t;#endifstatic void regmust();#pragma segment dfastatic ptr_txcalloc(n, s) int n; size_t s;{ ptr_t r = calloc(n, s); if (r) return r; else regerror("Memory exhausted");}static ptr_txmalloc(n) size_t n;{ ptr_t r = malloc(n); if (r) return r; else regerror("Memory exhausted");}static ptr_txrealloc(p, n) ptr_t p; size_t n;{ ptr_t r = realloc(p, n); if (r) return r; else regerror("Memory exhausted");}#define CALLOC(p, t, n) ((p) = (t *) xcalloc((n), sizeof (t)))#define MALLOC(p, t, n) ((p) = (t *) xmalloc((n) * sizeof (t)))#define REALLOC(p, t, n) ((p) = (t *) xrealloc((ptr_t) (p), (n) * sizeof (t)))/* Reallocate an array of type t if nalloc is too small for index. */#define REALLOC_IF_NECESSARY(p, t, nalloc, index) \ if ((index) >= (nalloc)) \ { \ while ((index) >= (nalloc)) \ (nalloc) *= 2; \ REALLOC(p, t, nalloc); \ } /* Stuff pertaining to charsets. */statictstbit(b, c) int b; _charset c;{ return c[b / INTBITS] & 1 << b % INTBITS;}static voidsetbit(b, c) int b; _charset c;{ c[b / INTBITS] |= 1 << b % INTBITS;}static voidclrbit(b, c) int b; _charset c;{ c[b / INTBITS] &= ~(1 << b % INTBITS);}static voidcopyset(src, dst) const _charset src; _charset dst;{ int i; for (i = 0; i < _CHARSET_INTS; ++i) dst[i] = src[i];}static voidzeroset(s) _charset s;{ int i; for (i = 0; i < _CHARSET_INTS; ++i) s[i] = 0;}static voidnotset(s) _charset s;{ int i; for (i = 0; i < _CHARSET_INTS; ++i) s[i] = ~s[i];}staticequal(s1, s2) const _charset s1; const _charset s2;{ int i; for (i = 0; i < _CHARSET_INTS; ++i) if (s1[i] != s2[i]) return 0; return 1;} /* A pointer to the current regexp is kept here during parsing. */static struct regexp *reg;/* Find the index of charset s in reg->charsets, or allocate a new charset. */staticcharset_index(s) const _charset s;{ int i; for (i = 0; i < reg->cindex; ++i) if (equal(s, reg->charsets[i])) return i; REALLOC_IF_NECESSARY(reg->charsets, _charset, reg->calloc, reg->cindex); ++reg->cindex; copyset(s, reg->charsets[i]); return i;}/* Syntax bits controlling the behavior of the lexical analyzer. */static syntax_bits, syntax_bits_set;/* Flag for case-folding letters into sets. */static case_fold;/* Entry point to set syntax options. */voidregsyntax(bits, fold) int bits; int fold;{ syntax_bits_set = 1; syntax_bits = bits; case_fold = fold;}/* Lexical analyzer. */static const char *lexstart; /* Pointer to beginning of input string. */static const char *lexptr; /* Pointer to next input character. */static lexleft; /* Number of characters remaining. */static caret_allowed; /* True if backward context allows ^ (meaningful only if RE_CONTEXT_INDEP_OPS is turned off). */static closure_allowed; /* True if backward context allows closures (meaningful only if RE_CONTEXT_INDEP_OPS is turned off). *//* Note that characters become unsigned here. */#define FETCH(c, eoferr) \ { \ if (! lexleft) \ if (eoferr) \ regerror(eoferr); \ else \ return _END; \ (c) = (unsigned char) *lexptr++; \ --lexleft; \ }static int starnext=0;static _tokenlex(){ _token c, c2; int invert; _charset cset; if (starnext) { starnext = 0; /* Fake ≈ == .* */ return _STAR; } FETCH(c, (char *) 0); switch (c) { case 0xA5: if (! (syntax_bits & RE_CONTEXT_INDEP_OPS) && (!caret_allowed || (syntax_bits & RE_TIGHT_VBAR) && lexptr - 1 != lexstart)) goto normal_char; caret_allowed = 0; return syntax_bits & RE_TIGHT_VBAR ? _ALLBEGLINE : _BEGLINE; case 0xB0: if (syntax_bits & RE_CONTEXT_INDEP_OPS || !lexleft || (! (syntax_bits & RE_TIGHT_VBAR) && ((syntax_bits & RE_NO_BK_PARENS ? lexleft > 0 && *lexptr == ')' : lexleft > 1 && *lexptr == 0xB6 && lexptr[1] == 0xB6) || (syntax_bits & RE_NO_BK_VBAR ? lexleft > 0 && *lexptr == '|' : lexleft > 1 && *lexptr == 0xB6 && lexptr[1] == '|')))) return syntax_bits & RE_TIGHT_VBAR ? _ALLENDLINE : _ENDLINE; goto normal_char; case ((unsigned char) 0xA8): FETCH(c, "Incorrect use of ®"); if (c >= '1' && c <= '9') { caret_allowed = 0; closure_allowed = 1; return _BACKREF; } goto normal_char; case 0xB6: FETCH(c, "Unfinished ∂ quote"); switch (c) { case '<': caret_allowed = 0; return _BEGWORD; case '>': caret_allowed = 0; return _ENDWORD; case 'b': caret_allowed = 0; return _LIMWORD; case 'B': caret_allowed = 0; return _NOTLIMWORD; case 'w': case 'W': zeroset(cset); for (c2 = 0; c2 < _NOTCHAR; ++c2) if (ISALNUM(c2)) setbit(c2, cset); if (c == 'W') notset(cset); caret_allowed = 0; closure_allowed = 1; return _SET + charset_index(cset); case 0xC0: if (syntax_bits & RE_BK_PLUS_QM) goto qmark; goto normal_char; case '+': if (syntax_bits & RE_BK_PLUS_QM) goto plus; goto normal_char; case '|': if (! (syntax_bits & RE_NO_BK_VBAR)) goto or; goto normal_char; case '(': if (! (syntax_bits & RE_NO_BK_PARENS)) goto lparen; goto normal_char; case ')': if (! (syntax_bits & RE_NO_BK_PARENS)) goto rparen; goto normal_char; default: goto normal_char; } case 0xC0: if (syntax_bits & RE_BK_PLUS_QM) goto normal_char; qmark: if (! (syntax_bits & RE_CONTEXT_INDEP_OPS) && !closure_allowed) goto normal_char; return _QMARK; case '*': if (! (syntax_bits & RE_CONTEXT_INDEP_OPS) && !closure_allowed) goto normal_char; return _STAR; case '+': if (syntax_bits & RE_BK_PLUS_QM) goto normal_char; plus: if (! (syntax_bits & RE_CONTEXT_INDEP_OPS) && !closure_allowed) goto normal_char; return _PLUS; case '|': if (! (syntax_bits & RE_NO_BK_VBAR)) goto normal_char; or: caret_allowed = 1; closure_allowed = 0; return _OR; case '\n': if (! (syntax_bits & RE_NEWLINE_OR)) goto normal_char; goto or; case '(': if (! (syntax_bits & RE_NO_BK_PARENS)) goto normal_char; lparen: caret_allowed = 1; closure_allowed = 0; return _LPAREN; case ')': if (! (syntax_bits & RE_NO_BK_PARENS)) goto normal_char; rparen: caret_allowed = 0; closure_allowed = 1; return _RPAREN; case 0xC5: starnext = 1; case '?': zeroset(cset); notset(cset); clrbit('\n', cset); caret_allowed = 0; closure_allowed = 1; return _SET + charset_index(cset); case '[': zeroset(cset); FETCH(c, "Unbalanced ["); if (c == 0xC2) { FETCH(c, "Unbalanced ["); invert = 1; } else invert = 0; do { FETCH(c2, "Unbalanced ["); if (c2 == '-') { FETCH(c2, "Unbalanced ["); while (c <= c2) setbit(c++, cset); FETCH(c, "Unbalanced ["); } else { setbit(c, cset); c = c2; } } while (c != ']'); if (invert) notset(cset); caret_allowed = 0; closure_allowed = 1; return _SET + charset_index(cset); default: normal_char: caret_allowed = 0; closure_allowed = 1; if (case_fold && ISALPHA(c)) { zeroset(cset); if (isupper(c)) c = tolower(c); setbit(c, cset); setbit(toupper(c), cset); return _SET + charset_index(cset); } return c; }} /* Recursive descent parser for regular expressions. */static _token tok; /* Lookahead token. */static depth; /* Current depth of a hypothetical stack holding deferred productions. This is used to determine the depth that will be required of the real stack later on in reganalyze(). *//* Add the given token to the parse tree, maintaining the depth count and updating the maximum depth if necessary. */static voidaddtok(t) _token t;{ REALLOC_IF_NECESSARY(reg->tokens, _token, reg->talloc, reg->tindex); reg->tokens[reg->tindex++] = t; switch (t) { case _QMARK: case _STAR: case _PLUS: break; case _CAT: case _OR: --depth; break; default: ++reg->nleaves; case _EMPTY: ++depth; break; } if (depth > reg->depth) reg->depth = depth;}/* The grammar understood by the parser is as follows. start: regexp _ALLBEGLINE regexp regexp _ALLENDLINE _ALLBEGLINE regexp _ALLENDLINE regexp: regexp _OR branch branch branch: branch closure closure closure: closure _QMARK closure _STAR closure _PLUS atom atom: <normal character> _SET _BACKREF _BEGLINE _ENDLINE _BEGWORD _ENDWORD _LIMWORD _NOTLIMWORD <empty> The parser builds a parse tree in postfix form in an array of tokens. */#ifdef __STDC__static void regexp(void);#elsestatic void regexp();#endifstatic voidatom(){ if (tok >= 0 && tok < _NOTCHAR || tok >= _SET || tok == _BACKREF || tok == _BEGLINE || tok == _ENDLINE || tok == _BEGWORD || tok == _ENDWORD || tok == _LIMWORD || tok == _NOTLIMWORD) { addtok(tok); tok = lex(); } else if (tok == _LPAREN) { tok = lex(); regexp(); if (tok != _RPAREN) regerror("Unbalanced ("); tok = lex(); } else addtok(_EMPTY);}static voidclosure(){ atom(); while (tok == _QMARK || tok == _STAR || tok == _PLUS) { addtok(tok); tok = lex(); }}static voidbranch(){ closure(); while (tok != _RPAREN && tok != _OR && tok != _ALLENDLINE && tok >= 0) { closure(); addtok(_CAT); }}static voidregexp(){ branch(); while (tok == _OR) { tok = lex(); branch(); addtok(_OR); }}/* Main entry point for the parser. S is a stri
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:e?grep ƒ:dfa.c
+++++ Continued from previous card +++++
ng to be parsed, len is the length of the string, so s can include NUL characters. R is a pointer to the struct regexp to parse into. */voidregparse(s, len, r) const char *s; size_t len; struct regexp *r;{ reg = r; lexstart = lexptr = s; lexleft = len; caret_allowed = 1; closure_allowed = 0; if (! syntax_bits_set) regerror("No syntax specified"); tok = lex(); depth = r->depth; if (tok == _ALLBEGLINE) { addtok(_BEGLINE); tok = lex(); regexp(); addtok(_CAT); } else regexp(); if (tok == _ALLENDLINE) { addtok(_ENDLINE); addtok(_CAT); tok = lex(); } if (tok != _END) regerror("Unbalanced )"); addtok(_END - r->nregexps); addtok(_CAT); if (r->nregexps) addtok(_OR); ++r->nregexps;} /* Some primitives for operating on sets of positions. *//* Copy one set to another; the destination must be large enough. */static voidcopy(src, dst) const _position_set *src; _position_set *dst;{ int i; for (i = 0; i < src->nelem; ++i) dst->elems[i] = src->elems[i]; dst->nelem = src->nelem;}/* Insert a position in a set. Position sets are maintained in sorted order according to index. If position already exists in the set with the same index then their constraints are logically or'd together. S->elems must point to an array large enough to hold the resulting set. */static voidinsert(p, s) _position p; _position_set *s;{ int i; _position t1, t2; for (i = 0; i < s->nelem && p.index < s->elems[i].index; ++i) ; if (i < s->nelem && p.index == s->elems[i].index) s->elems[i].constraint |= p.constraint; else { t1 = p; ++s->nelem; while (i < s->nelem) { t2 = s->elems[i]; s->elems[i++] = t1; t1 = t2; } }}/* Merge two sets of positions into a third. The result is exactly as if the positions of both sets were inserted into an initially empty set. */static voidmerge(s1, s2, m) _position_set *s1; _position_set *s2; _position_set *m;{ int i = 0, j = 0; m->nelem = 0; while (i < s1->nelem && j < s2->nelem) if (s1->elems[i].index > s2->elems[j].index) m->elems[m->nelem++] = s1->elems[i++]; else if (s1->elems[i].index < s2->elems[j].index) m->elems[m->nelem++] = s2->elems[j++]; else { m->elems[m->nelem] = s1->elems[i++]; m->elems[m->nelem++].constraint |= s2->elems[j++].constraint; } while (i < s1->nelem) m->elems[m->nelem++] = s1->elems[i++]; while (j < s2->nelem) m->elems[m->nelem++] = s2->elems[j++];}/* Delete a position from a set. */static voiddelete(p, s) _position p; _position_set *s;{ int i; for (i = 0; i < s->nelem; ++i) if (p.index == s->elems[i].index) break; if (i < s->nelem) for (--s->nelem; i < s->nelem; ++i) s->elems[i] = s->elems[i + 1];} /* Find the index of the state corresponding to the given position set with the given preceding context, or create a new state if there is no such state. Newline and letter tell whether we got here on a newline or letter, respectively. */staticstate_index(r, s, newline, letter) struct regexp *r; _position_set *s; int newline; int letter;{ int hash = 0; int constraint; int i, j; newline = newline ? 1 : 0; letter = letter ? 1 : 0; for (i = 0; i < s->nelem; ++i) hash ^= s->elems[i].index + s->elems[i].constraint; /* Try to find a state that exactly matches the proposed one. */ for (i = 0; i < r->sindex; ++i) { if (hash != r->states[i].hash || s->nelem != r->states[i].elems.nelem || newline != r->states[i].newline || letter != r->states[i].letter) continue; for (j = 0; j < s->nelem; ++j) if (s->elems[j].constraint != r->states[i].elems.elems[j].constraint || s->elems[j].index != r->states[i].elems.elems[j].index) break; if (j == s->nelem) return i; } /* We'll have to create a new state. */ REALLOC_IF_NECESSARY(r->states, _dfa_state, r->salloc, r->sindex); r->states[i].hash = hash; MALLOC(r->states[i].elems.elems, _position, s->nelem); copy(s, &r->states[i].elems); r->states[i].newline = newline; r->states[i].letter = letter; r->states[i].backref = 0; r->states[i].constraint = 0; r->states[i].first_end = 0; for (j = 0; j < s->nelem; ++j) if (r->tokens[s->elems[j].index] < 0) { constraint = s->elems[j].constraint; if (_SUCCEEDS_IN_CONTEXT(constraint, newline, 0, letter, 0) || _SUCCEEDS_IN_CONTEXT(constraint, newline, 0, letter, 1) || _SUCCEEDS_IN_CONTEXT(constraint, newline, 1, letter, 0) || _SUCCEEDS_IN_CONTEXT(constraint, newline, 1, letter, 1)) r->states[i].constraint |= constraint; if (! r->states[i].first_end) r->states[i].first_end = r->tokens[s->elems[j].index]; } else if (r->tokens[s->elems[j].index] == _BACKREF) { r->states[i].constraint = _NO_CONSTRAINT; r->states[i].backref = 1; } ++r->sindex; return i;} /* Find the epsilon closure of a set of positions. If any position of the set contains a symbol that matches the empty string in some context, replace that position with the elements of its follow labeled with an appropriate constraint. Repeat exhaustively until no funny positions are left. S->elems must be large enough to hold the result. */epsclosure(s, r) _position_set *s; struct regexp *r;{ int i, j; int *visited; _position p, old; MALLOC(visited, int, r->tindex); for (i = 0; i < r->tindex; ++i) visited[i] = 0; for (i = 0; i < s->nelem; ++i) if (r->tokens[s->elems[i].index] >= _NOTCHAR && r->tokens[s->elems[i].index] != _BACKREF && r->tokens[s->elems[i].index] < _SET) { old = s->elems[i]; p.constraint = old.constraint; delete(s->elems[i], s); if (visited[old.index]) { --i; continue; } visited[old.index] = 1; switch (r->tokens[old.index]) { case _BEGLINE: p.constraint &= _BEGLINE_CONSTRAINT; break; case _ENDLINE: p.constraint &= _ENDLINE_CONSTRAINT; break; case _BEGWORD: p.constraint &= _BEGWORD_CONSTRAINT; break; case _ENDWORD: p.constraint &= _ENDWORD_CONSTRAINT; break; case _LIMWORD: p.constraint &= _ENDWORD_CONSTRAINT; break; case _NOTLIMWORD: p.constraint &= _NOTLIMWORD_CONSTRAINT; break; } for (j = 0; j < r->follows[old.index].nelem; ++j) { p.index = r->follows[old.index].elems[j].index; insert(p, s); } /* Force rescan to start at the beginning. */ i = -1; } free(visited);} /* Perform bottom-up analysis on the parse tree, computing various functions. Note that at this point, we're pretending constructs like \< are real characters rather than constraints on what can follow them. Nullable: A node is nullable if it is at the root of a regexp that can match the empty string. * _EMPTY leaves are nullable. * No other leaf is nullable. * A _QMARK or _STAR node is nullable. * A _PLUS node is nullable if its argument is nullable. * A _CAT node is nullable if both its arguments are nullable. * An _OR node is nullable if either argument is nullable. Firstpos: The firstpos of a node is the set of positions (nonempty leaves) that could correspond to the first character of a string matching the regexp rooted at the given node. * _EMPTY leaves have empty firstpos. * The firstpos of a nonempty leaf is that leaf itself. * The firstpos of a _QMARK, _STAR, or _PLUS node is the firstpos of its argument. * The firstpos of a _CAT node is the firstpos of the left argument, union the firstpos of the right if the left argument is nullable. * The firstpos of an _OR node is the union of firstpos of each argument. Lastpos: The lastpos of a node is the set of positions that could correspond to the last character of a string matching the regexp at the given node. * _EMPTY leaves have empty lastpos. * The lastpos of a nonempty leaf is that leaf itself. * The lastpos of a _QMARK, _STAR, or _PLUS node is the lastpos of its argument. * The lastpos of a _CAT node is the lastpos of its right argument, union the lastpos of the left if the right argument is nullable. * The lastpos of an _OR node is the union of the lastpos of each argument. Follow: The follow of a position is the set of positions that could correspond to the character following a character matching the node in a string matching the regexp. At this point we consider special symbols that match the empty string in some context to be just normal characters. Later, if we find that a special symbol is in a follow set, we will replace it with the elements of its follow, labeled with an appropriate constraint. * Every node in the firstpos of the argument of a _STAR or _PLUS node is in the follow of every node in the lastpos. * Every node in the firstpos of the second argument of a _CAT node is in the follow of every node in the lf the first argument. Because of the postfix representation of the parse tree, the depth-first analysis is conveniently done by a linear scan with the aid of a stack. Sets are stored as arrays of the elements, obeying a stack-like allocation scheme; the number of elements in each set deeper in the stack can be used to determine the address of a particular set's array. */voidreganalyze(r, searchflag) struct regexp *r; int searchflag;{ int *nullable; /* Nullable stack. */ int *nfirstpos; /* Element count stack for firstpos sets. */ _position *firstpos; /* Array where firstpos elements are stored. */ int *nlastpos; /* Element count stack for lastpos sets. */ _position *lastpos; /* Array where lastpos elements are stored. */ int *nalloc; /* Sizes of arrays allocated to follow sets. */ _position_set tmp; /* Temporary set for merging sets. */ _position_set merged; /* Result of merging sets. */ int wants_newline; /* True if some position wants newline info. */ int *o_nullable; int *o_nfirst, *o_nlast; _position *o_firstpos, *o_lastpos; int i, j; _position *pos; r->searchflag = searchflag; MALLOC(nullable, int, r->depth); o_nullable = nullable; MALLOC(nfirstpos, int, r->depth); o_nfirst = nfirstpos; MALLOC(firstpos, _position, r->nleaves); o_firstpos = firstpos, firstpos += r->nleaves; MALLOC(nlastpos, int, r->depth); o_nlast = nlastpos; MALLOC(lastpos, _position, r->nleaves); o_lastpos = lastpos, lastpos += r->nleaves; MALLOC(nalloc, int, r->tindex); for (i = 0; i < r->tindex; ++i) nalloc[i] = 0; MALLOC(merged.elems, _position, r->nleaves); CALLOC(r->follows, _position_set, r->tindex); for (i = 0; i < r->tindex; ++i) switch (r->tokens[i]) { case _EMPTY: /* The empty set is nullable. */ *nullable++ = 1; /* The firstpos and lastpos of the empty leaf are both empty. */ *nfirstpos++ = *nlastpos++ = 0; break; case _STAR: case _PLUS: /* Every element in the firstpos of the argument is in the follow of every element in the lastpos. */ tmp.nelem = nfirstpos[-1]; tmp.elems = firstpos; pos = lastpos; for (j = 0; j < nlastpos[-1]; ++j) { merge(&tmp, &r->follows[pos[j].index], &merged); REALLOC_IF_NECESSARY(r->follows[pos[j].index].elems, _position, nalloc[pos[j].index], merged.nelem - 1); copy(&merged, &r->follows[pos[j].index]); } case _QMARK: /* A _QMARK or _STAR node is automatically nullable. */ if (r->tokens[i] != _PLUS) nullable[-1] = 1; break; case _CAT: /* Every element in the firstpos of the second argument is in the follow of every element in the lastpos of the first argument. */ tmp.nelem = nfirstpos[-1]; tmp.elems = firstpos; pos = lastpos + nlastpos[-1]; for (j = 0; j < nlastpos[-2]; ++j) { merge(&tmp, &r->follows[pos[j].index], &merged); REALLOC_IF_NECESSARY(r->follows[pos[j].index].elems, _position, nalloc[pos[j].index], merged.nelem - 1); copy(&merged, &r->follows[pos[j].index]); } /* The firstpos of a _CAT node is the firstpos of the first argument, union that of the second argument if the first is nullable. */ if (nullable[-2]) nfirstpos[-2] += nfirstpos[-1]; else firstpos += nfirstpos[-1]; --nfirstpos; /* The lastpos of a _CAT node is the lastpos of the second argument, union that of the first argument if the second is nullable. */ if (nullable[-1]) nlastpos[-2] += nlastpos[-1]; else { pos = lastpos + nlastpos[-2]; for (j = nlastpos[-1] - 1; j >= 0; --j) pos[j] = lastpos[j]; lastpos += nlastpos[-2]; nlastpos[-2] = nlastpos[-1]; } --nlastpos; /* A _CAT node is nullable if both arguments are nullable. */ nullable[-2] = nullable[-1] && nullable[-2]; --nullable; break; case _OR: /* The firstpos is the union of the firstpos of each argument. */ nfirstpos[-2] += nfirstpos[-1]; --nfirstpos; /* The lastpos is the union of the lastpos of each argument. */ nlastpos[-2] += nlastpos[-1]; --nlastpos; /* An _OR node is nullable if either argument is nullable. */ nullable[-2] = nullable[-1] || nullable[-2]; --nullable; break; default: /* Anything else is a nonempty position. (Note that special constructs like \< are treated as nonempty strings here; an "epsilon closure" effectively makes them nullable later. Backreferences have to get a real position so we can detect transitions on them later. But they are nullable. */ *nullable++ = r->tokens[i] == _BACKREF; /* This position is in its own firstpos and lastpos. */ *nfirstpos++ = *nlastpos++ = 1; --firstpos, --lastpos; firstpos->index = lastpos->index = i; firstpos->constraint = lastpos->constraint = _NO_CONSTRAINT; /* Allocate the follow set for this position. */ nalloc[i] = 1; MALLOC(r->follows[i].elems, _position, nalloc[i]); break; } /* For each follow set that is the follow set of a real position, replace it with its epsilon closure. */ for (i = 0; i < r->tindex; ++i) if (r->tokens[i] < _NOTCHAR || r->tokens[i] == _BACKREF || r->tokens[i] >= _SET) { copy(&r->follows[i], &merged); epsclosure(&merged, r); REALLOC(r->follows[i].elems, _position, merged.nelem); copy(&merged, &r->follows[i]); } /* Get the epsilon closure of the firstpos of the regexp. The result will be the set of positions of state 0. */ merged.nelem = 0; for (i = 0; i < nfirstpos[-1]; ++i) insert(firstpos[i], &merged); epsclosure(&merged, r); /* Check if any of the positions of state 0 will want newline context. */ wants_newline = 0; for (i = 0; i < merged.nelem; ++i) if (_PREV_NEWLINE_DEPENDENT(merged.elems[i].constraint)) wants_newline = 1; /* Build the initial state. */ r->salloc = 1; r->sindex = 0; MALLOC(r->states, _dfa_state, r->salloc); state_index(r, &merged, wants_newline, 0); free(o_nullable); free(o_nfirst); free(o_firstpos); free(o_nlast); free(o_lastpos); free(nalloc); free(merged.elems);} /* Find, for each character, the transition out of state s of r, and store it in the appropriate slot of trans. We divide the positions of s into groups (positions can appear in more than one group). Each group is labeled with a set of characters that every position in the group matches (taking into account, if necessary, preceding context information of s). For each group, find the union of the its elements' follows. This set is the set of positions of the new state. For each character in the group's label, set the transition on this character to be to a state corresponding to the set's positions, and its associated backward context information, if necessary.
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:e?grep ƒ:dfa.c
+++++ Continued from previous card +++++
If we are building a searching matcher, we include the positions of state 0 in every state. The collection of groups is constructed by building an equivalence-class partition of the positions of s. For each position, find the set of characters C that it matches. Eliminate any characters from C that fail on grounds of backward context. Search through the groups, looking for a group whose label L has nonempty intersection with C. If L - C is nonempty, create a new group labeled L - C and having the same positions as the current group, and set L to the intersection of L and C. Insert the position in this group, set C = C - L, and resume scanning. If after comparing with every group there are characters remaining in C, create a new group labeled with the characters of C and insert this position in that group. */voidregstate(s, r, trans) int s; struct regexp *r; int trans[];{ _position_set grps[_NOTCHAR]; /* As many as will ever be needed. */ _charset labels[_NOTCHAR]; /* Labels corresponding to the groups. */ int ngrps = 0; /* Number of groups actually used. */ _position pos; /* Current position being considered. */ _charset matches; /* Set of matching characters. */ int matchesf; /* True if matches is nonempty. */ _charset intersect; /* Intersection with some label set. */ int intersectf; /* True if intersect is nonempty. */ _charset leftovers; /* Stuff in the label that didn't match. */ int leftoversf; /* True if leftovers is nonempty. */ static _charset letters; /* Set of characters considered letters. */ static _charset newline; /* Set of characters that aren't newline. */ _position_set follows; /* Union of the follows of some group. */ _position_set tmp; /* Temporary space for merging sets. */ int state; /* New state. */ int wants_newline; /* New state wants to know newline context. */ int state_newline; /* New state on a newline transition. */ int wants_letter; /* New state wants to know letter context. */ int state_letter; /* New state on a letter transition. */ static initialized; /* Flag for static initialization. */ int i, j, k; /* Initialize the set of letters, if necessary. */ if (! initialized) { initialized = 1; for (i = 0; i < _NOTCHAR; ++i) if (ISALNUM(i)) setbit(i, letters); setbit('\n', newline); } zeroset(matches); for (i = 0; i < r->states[s].elems.nelem; ++i) { pos = r->states[s].elems.elems[i]; if (r->tokens[pos.index] >= 0 && r->tokens[pos.index] < _NOTCHAR) setbit(r->tokens[pos.index], matches); else if (r->tokens[pos.index] >= _SET) copyset(r->charsets[r->tokens[pos.index] - _SET], matches); else continue; /* Some characters may need to be climinated from matches because they fail in the current context. */ if (pos.constraint != 0xff) { if (! _MATCHES_NEWLINE_CONTEXT(pos.constraint, r->states[s].newline, 1)) clrbit('\n', matches); if (! _MATCHES_NEWLINE_CONTEXT(pos.constraint, r->states[s].newline, 0)) for (j = 0; j < _CHARSET_INTS; ++j) matches[j] &= newline[j]; if (! _MATCHES_LETTER_CONTEXT(pos.constraint, r->states[s].letter, 1)) for (j = 0; j < _CHARSET_INTS; ++j) matches[j] &= ~letters[j]; if (! _MATCHES_LETTER_CONTEXT(pos.constraint, r->states[s].letter, 0)) for (j = 0; j < _CHARSET_INTS; ++j) matches[j] &= letters[j]; /* If there are no characters left, there's no point in going on. */ for (j = 0; j < _CHARSET_INTS && !matches[j]; ++j) ; if (j == _CHARSET_INTS) continue; } for (j = 0; j < ngrps; ++j) { /* If matches contains a single character only, and the current group's label doesn't contain that character, go on to the next group. */ if (r->tokens[pos.index] >= 0 && r->tokens[pos.index] < _NOTCHAR && !tstbit(r->tokens[pos.index], labels[j])) continue; /* Check if this group's label has a nonempty intersection with matches. */ intersectf = 0; for (k = 0; k < _CHARSET_INTS; ++k) (intersect[k] = matches[k] & labels[j][k]) ? intersectf = 1 : 0; if (! intersectf) continue; /* It does; now find the set differences both ways. */ leftoversf = matchesf = 0; for (k = 0; k < _CHARSET_INTS; ++k) { /* Even an optimizing compiler can't know this for sure. */ int match = matches[k], label = labels[j][k]; (leftovers[k] = ~match & label) ? leftoversf = 1 : 0; (matches[k] = match & ~label) ? matchesf = 1 : 0; } /* If there were leftovers, create a new group labeled with them. */ if (leftoversf) { copyset(leftovers, labels[ngrps]); copyset(intersect, labels[j]); MALLOC(grps[ngrps].elems, _position, r->nleaves); copy(&grps[j], &grps[ngrps]); ++ngrps; } /* Put the position in the current group. Note that there is no reason to call insert() here. */ grps[j].elems[grps[j].nelem++] = pos; /* If every character matching the current position has been accounted for, we're done. */ if (! matchesf) break; } /* If we've passed the last group, and there are still characters unaccounted for, then we'll have to create a new group. */ if (j == ngrps) { copyset(matches, labels[ngrps]); zeroset(matches); MALLOC(grps[ngrps].elems, _position, r->nleaves); grps[ngrps].nelem = 1; grps[ngrps].elems[0] = pos; ++ngrps; } } MALLOC(follows.elems, _position, r->nleaves); MALLOC(tmp.elems, _position, r->nleaves); /* If we are a searching matcher, the default transition is to a state containing the positions of state 0, otherwise the default transition is to fail miserably. */ if (r->searchflag) { wants_newline = 0; wants_letter = 0; for (i = 0; i < r->states[0].elems.nelem; ++i) { if (_PREV_NEWLINE_DEPENDENT(r->states[0].elems.elems[i].constraint)) wants_newline = 1; if (_PREV_LETTER_DEPENDENT(r->states[0].elems.elems[i].constraint)) wants_letter = 1; } copy(&r->states[0].elems, &follows); state = state_index(r, &follows, 0, 0); if (wants_newline) state_newline = state_index(r, &follows, 1, 0); else state_newline = state; if (wants_letter) state_letter = state_index(r, &follows, 0, 1); else state_letter = state; for (i = 0; i < _NOTCHAR; ++i) if (i == '\n') trans[i] = state_newline; else if (ISALNUM(i)) trans[i] = state_letter; else trans[i] = state; } else for (i = 0; i < _NOTCHAR; ++i) trans[i] = -1; for (i = 0; i < ngrps; ++i) { follows.nelem = 0; /* Find the union of the follows of the positions of the group. This is a hideously inefficient loop. Fix it someday. */ for (j = 0; j < grps[i].nelem; ++j) for (k = 0; k < r->follows[grps[i].elems[j].index].nelem; ++k) insert(r->follows[grps[i].elems[j].index].elems[k], &follows); /* If we are building a searching matcher, throw in the positions of state 0 as well. */ if (r->searchflag) for (j = 0; j < r->states[0].elems.nelem; ++j) insert(r->states[0].elems.elems[j], &follows); /* Find out if the new state will want any context information. */ wants_newline = 0; if (tstbit('\n', labels[i])) for (j = 0; j < follows.nelem; ++j) if (_PREV_NEWLINE_DEPENDENT(follows.elems[j].constraint)) wants_newline = 1; wants_letter = 0; for (j = 0; j < _CHARSET_INTS; ++j) if (labels[i][j] & letters[j]) break; if (j < _CHARSET_INTS) for (j = 0; j < follows.nelem; ++j) if (_PREV_LETTER_DEPENDENT(follows.elems[j].constraint)) wants_letter = 1; /* Find the state(s) corresponding to the union of the follows. */ state = state_index(r, &follows, 0, 0); if (wants_newline) state_newline = state_index(r, &follows, 1, 0); else state_newline = state; if (wants_letter) state_letter = state_index(r, &follows, 0, 1); else state_letter = state; /* Set the transitions for each character in the current label. */ for (j = 0; j < _CHARSET_INTS; ++j) for (k = 0; k < INTBITS; ++k) if (labels[i][j] & 1 << k) { int c = j * INTBITS + k; if (c == '\n') trans[c] = state_newline; else if (ISALNUM(c)) trans[c] = state_letter; else if (c < _NOTCHAR) trans[c] = state; } } for (i = 0; i < ngrps; ++i) free(grps[i].elems); free(follows.elems); free(tmp.elems);} /* Some routines for manipulating a compiled regexp's transition tables. Each state may or may not have a transition table; if it does, and it is a non-accepting state, then r->trans[state] points to its table. If it is an accepting state then r->fails[state] points to its table. If it has no table at all, then r->trans[state] is NULL. TODO: Improve this comment, get rid of the unnecessary redundancy. */static voidbuild_state(s, r) int s; struct regexp *r;{ int *trans; /* The new transition table. */ int i; /* Set an upper limit on the number of transition tables that will ever exist at once. 1024 is arbitrary. The idea is that the frequently used transition tables will be quickly rebuilt, whereas the ones that were only needed once or twice will be cleared away. */ if (r->trcount >= 1024) { for (i = 0; i < r->tralloc; ++i) if (r->trans[i]) { free((ptr_t) r->trans[i]); r->trans[i] = NULL; } else if (r->fails[i]) { free((ptr_t) r->fails[i]); r->fails[i] = NULL; } r->trcount = 0; } ++r->trcount; /* Set up the success bits for this state. */ r->success[s] = 0; if (ACCEPTS_IN_CONTEXT(r->states[s].newline, 1, r->states[s].letter, 0, s, *r)) r->success[s] |= 4; if (ACCEPTS_IN_CONTEXT(r->states[s].newline, 0, r->states[s].letter, 1, s, *r)) r->success[s] |= 2; if (ACCEPTS_IN_CONTEXT(r->states[s].newline, 0, r->states[s].letter, 0, s, *r)) r->success[s] |= 1; MALLOC(trans, int, _NOTCHAR); regstate(s, r, trans); /* Now go through the new transition table, and make sure that the trans and fail arrays are allocated large enough to hold a pointer for the largest state mentioned in the table. */ for (i = 0; i < _NOTCHAR; ++i) if (trans[i] >= r->tralloc) { int oldalloc = r->tralloc; while (trans[i] >= r->tralloc) r->tralloc *= 2; REALLOC(r->realtrans, int *, r->tralloc + 1); r->trans = r->realtrans + 1; REALLOC(r->fails, int *, r->tralloc); REALLOC(r->success, int, r->tralloc); REALLOC(r->newlines, int, r->tralloc); while (oldalloc < r->tralloc) { r->trans[oldalloc] = NULL; r->fails[oldalloc++] = NULL; } } /* Keep the newline transition in a special place so we can use it as a sentinel. */ r->newlines[s] = trans['\n']; trans['\n'] = -1; if (ACCEPTING(s, *r)) r->fails[s] = trans; else r->trans[s] = trans;}static voidbuild_state_zero(r) struct regexp *r;{ r->tralloc = 1; r->trcount = 0; CALLOC(r->realtrans, int *, r->tralloc + 1); r->trans = r->realtrans + 1; CALLOC(r->fails, int *, r->tralloc); MALLOC(r->success, int, r->tralloc); MALLOC(r->newlines, int, r->tralloc); build_state(0, r);} /* Search through a buffer looking for a match to the given struct regexp. Find the first occurrence of a string matching the regexp in the buffer, and the shortest possible version thereof. Return a pointer to the first character after the match, or NULL if none is found. Begin points to the beginning of the buffer, and end points to the first character after its end. We store a newline in *end to act as a sentinel, so end had better point somewhere valid. Newline is a flag indicating whether to allow newlines to be in the matching string. If count is non- NULL it points to a place we're supposed to increment every time we see a newline. Finally, if backref is non-NULL it points to a place where we're supposed to store a 1 if backreferencing happened and the match needs to be verified by a backtracking matcher. Otherwise we store a 0 in *backref. */char *regexecute(r, begin, end, newline, count, backref) struct regexp *r; char *begin; char *end; int newline; int *count; int *backref;{ register s, s1, tmp; /* Current state. */ register unsigned char *p; /* Current input character. */ register **trans, *t; /* Copy of r->trans so it can be optimized into a register. */ static sbit[_NOTCHAR]; /* Table for anding with r->success. */ static sbit_init; if (! sbit_init) { int i; sbit_init = 1; for (i = 0; i < _NOTCHAR; ++i) if (i == '\n') sbit[i] = 4; else if (ISALNUM(i)) sbit[i] = 2; else sbit[i] = 1; } if (! r->tralloc) build_state_zero(r); s = 0; p = (unsigned char *) begin; trans = r->trans; *end = '\n'; for (;;) { /* The dreaded inner loop. */ if (t = trans[s]) do { s1 = t[*p++]; if (! (t = trans[s1])) goto last_was_s; s = t[*p++]; } while (t = trans[s]); goto last_was_s1; last_was_s: tmp = s, s = s1, s1 = tmp; last_was_s1: if (s >= 0 && p <= (unsigned char *) end && r->fails[s]) { if (r->success[s] & sbit[*p]) { if (backref) if (r->states[s].backref) *backref = 1; else *backref = 0; return (char *) p; } s1 = s; s = r->fails[s][*p++]; continue; } /* If the previous character was a newline, count it. */ if (count && (char *) p <= end && p[-1] == '\n') ++*count; /* Check if we've run off the end of the buffer. */ if ((char *) p >= end) return NULL; if (s >= 0) { build_state(s, r); trans = r->trans; continue; } if (p[-1] == '\n' && newline) { s = r->newlines[s1]; continue; } s = 0; }} /* Initialize the components of a regexp that the other routines don't initialize for themselves. */voidreginit(r) struct regexp *r;{ r->calloc = 1; MALLOC(r->charsets, _charset, r->calloc); r->cindex = 0; r->talloc = 1; MALLOC(r->tokens, _token, r->talloc); r->tindex = r->depth = r->nleaves = r->nregexps = 0; r->searchflag = 0; r->tralloc = 0;}/* Parse and analyze a single string of the given length. */voidregcompile(s, len, r, searchflag) const char *s; size_t len; struct regexp *r; int searchflag;{ if (case_fold) /* dummy folding in service of regmust() */ { static char *p; case_fold = 0; for (p = (char *)s; *p != 0; p++) if (isupper((int)*p)) *p = tolower((int) *p); reginit(r); r->mustn = 0; r->must[0] = '\0'; regparse(s, len, r); regmust(r); reganalyze(r, searchflag); case_fold = 1; reginit(r); regparse(s, len, r); reganalyze(r, searchflag); } else { reginit(r); regparse(s, len, r); regmust(r); reganalyze(r, searchflag); }}/* Free the storage held by the components of a regexp. */voidregfree(r) struct regexp *r;{ int i; free((ptr_t) r->charsets); free((ptr_t) r->tokens); for (i = 0; i < r->sindex; ++i) free((ptr_t) r->states[i].elems.elems); free((ptr_t) r->states); for (i = 0; i < r->tindex; ++i) if (r->follows[i].elems) free((ptr_t) r->follows[i].elems); free((ptr_t) r->follows); for (i = 0; i < r->tralloc; ++i) if (r->trans[i]) free((ptr_t) r->trans[i]); else if (r->fails[i]) free((ptr_t) r->fails[i]); free((ptr_t) r->realtrans); free((ptr_t) r->fails); free((ptr_t) r->newlines);}/*Having found the postfix representation of the regular expression,try to find a long sequence of charac
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:e?grep ƒ:dfa.c
+++++ Continued from previous card +++++
ters that must appear in any linecontaining the r.e.Finding a "longest" sequence is beyond the scope of this bagatelle;we take the easy way out and hope for the best.We do a bottom-up calculation of several (possibly zero-length) sequencesof characters that must appear in matches of r.e.'s represented by treesrooted at the nodes of the postfix representation: sequences that must appear at the left of the match ("left") sequences that must appear at the right of the match ("right") sequences that must appear somewhere in the match ("in") sequences that must constitute the match ("is")When we get to the root of the tree, we use its calculated "in" sequenceas our answer. The sequence we find is returned in r->must (where "r" isthe single argument passed to "regmust"); the length of the sequence isreturned in r->mustn.The sequences calculated for the various types of node (in pseudo ANSI c)are shown below. "p" is the operand of unary operators (and the left-handoperand of binary operators); "q" is the right-hand operand of binary operators."ZERO" means "a zero-length sequence" below.Type left right is in---- ---- ----- -- --char c # c # c # c # cSET ZERO ZERO ZERO ZEROSTAR ZERO ZERO ZERO ZEROQMARK ZERO ZERO ZERO ZEROPLUS p->left p->right ZERO ZEROCAT (p->is==ZERO)? (q->is==ZERO)? (p->is!=ZERO && longest of p->left : q->right : q->is!=ZERO) ? p->in, q->in, or p->is##q->left p->right##q->is p->is##q->is : p->right##q->left ZEROOR longest common longest common (do p->is and (do p->in and leading trailing q->is have same q->in have same (sub)sequence (sub)sequence length and length and of p->left of p->right content) ? content) ? and q->left and q->right p->is : NULL p->in : NULLIf there's anything else we recognize in the tree, all four sequences get setto zero-length sequences. If there's something we don't recognize in the tree,we just return a zero-length sequence.After the above calculations are performed, three additional steps are taken:1. If there's a non-zero-length "is" sequence, it replaces the "left", "right", and "in" sequences.2. If the "left" sequence is longer than the "in" sequence, it replaces the "in" sequence.3. If the "right" sequence is longer than the "in" sequence, it replaces the "in" sequence.Possibilities:1. Find the longest common (sub)sequence of p->in and q->in when doing an OR node's "in" sequence? Possibly effective, as in egrep 'pepsi|epsilon' but is it cheap and easy enough?2. In replacing "in" sequences with "left" and "right" sequences, how should ties be broken?3. Switch to allocated memory, rather than relying on a defined MUST_MAX?*/#define TRUE 1#define FALSE 0typedef struct { int n; char p[MUST_MAX];} counted;#define initcounted(cp) ((cp)->n = 0)static voidcntcpy(top, fromp)counted * top;counted * fromp;{ register char * fp; register char * tp; register int n; fp = fromp->p; tp = top->p; n = fromp->n; top->n = n; while (n-- > 0) *tp++ = *fp++;}static voidcntcat(top, fromp)counted * top;counted * fromp;{ register char * fp; register char * tp; register int n; fp = fromp->p; tp = top->p + top->n; n = fromp->n; top->n += n; while (n-- > 0) *tp++ = *fp++;}static intcntsame(acp, bcp)counted * acp;counted * bcp;{ register int i; if (acp->n != bcp->n) return FALSE; for (i = 0; i < acp->n; ++i) if (acp->p[i] != bcp->p[i]) return FALSE; return TRUE;}typedef struct { counted left; counted right; counted in; counted is;} must;static voidinitmust(mp)must * mp;{ initcounted(&mp->left); initcounted(&mp->right); initcounted(&mp->in); initcounted(&mp->is);}static voidregmust(r)register struct regexp * r;{#pragma unused(r) must musts[MUST_MAX]; register must * mp; counted result; register int ri; register int i; register _token t; reg->mustn = 0; reg->must[0] = '\0'; if (reg->tindex > MUST_MAX) return; mp = musts; initcounted(&result); for (ri = 0; ri < reg->tindex; ++ri) { switch (t = reg->tokens[ri]) { case _ALLBEGLINE: case _ALLENDLINE: case _LPAREN: case _RPAREN: goto done; /* "cannot happen" */ case _EMPTY: case _BEGLINE: case _ENDLINE: case _BEGWORD: case _ENDWORD: case _LIMWORD: case _NOTLIMWORD: case _BACKREF: initmust(mp); break; case _STAR: case _QMARK: if (mp <= musts) goto done; /* "cannot happen" */ --mp; initmust(mp); break; case _OR: if (mp < &musts[2]) goto done; /* "cannot happen" */ { register must * lmp; register must * rmp; register int j, n; rmp = --mp; lmp = --mp; /* Guaranteed to be. Unlikely, but. . . */ if (!cntsame(&lmp->is, &rmp->is)) initcounted(&lmp->is); /* Left side--easy */ n = lmp->left.n; if (n > rmp->left.n) n = rmp->left.n; for (i = 0; i < n; ++i) if (lmp->left.p[i] != rmp->left.p[i]) break; lmp->left.n = i; /* Right side */ n = lmp->right.n; if (n > rmp->right.n) n = rmp->right.n; for (i = 0; i < n; ++i) if (lmp->right.p[lmp->right.n-i-1] != rmp->right.p[rmp->right.n-i-1]) break; for (j = 0; j < i; ++j) lmp->right.p[j] = lmp->right.p[(lmp->right.n - i) + j]; lmp->right.n = i; /* Includes. Unlikely, but. . . */ if (!cntsame(&lmp->in, &rmp->in)) initcounted(&lmp->in); } break; case _PLUS: if (mp <= musts) goto done; /* "cannot happen" */ --mp; initcounted(&mp->is); break; case _END: if (mp != &musts[1]) goto done; /* "cannot happen" */ result = musts[0].in; goto done; case _CAT: if (mp < &musts[2]) goto done; /* "cannot happen" */ { must * lmp; must * rmp; must new; must * nmp; int a, b, c; rmp = --mp; lmp = --mp; nmp = &new; initmust(nmp); /* Left-hand */ cntcat(&nmp->left, &lmp->left); if (lmp->is.n != 0) cntcat(&nmp->left, &rmp->left); /* Right-hand */ if (rmp->is.n != 0) cntcat(&nmp->right, &lmp->right); cntcat(&nmp->right, &rmp->right); /* Guaranteed to be */ if (lmp->is.n != 0 && rmp->is.n != 0) { cntcat(&nmp->is, &lmp->is); cntcat(&nmp->is, &rmp->is); } /* Interior */ a = lmp->in.n; b = rmp->in.n; c = lmp->right.n + rmp->left.n; if (a == 0 && b == 0 && c == 0) { /* nothing */ ; } else if (c > a && c > b) { cntcat(&nmp->in, &lmp->right); cntcat(&nmp->in, &rmp->left); } else if (a > b) { cntcat(&nmp->in, &lmp-> } else { cntcat(&nmp->in, &rmp->in); } *mp = new; } break; default: if (t < _END) { /* "cannot happen" */ goto done; } else if (t >= _SET) { /* easy enough */ initmust(mp); } else { /* plain character */ mp->left.p[0] = mp->right.p[0] = mp->in.p[0] = mp->is.p[0] = t; mp->left.n = mp->right.n = mp->in.n = mp->is.n = 1; break; } break; } /* ** "Additional steps" */ if (mp->is.n > 0) { cntcpy(&mp->left, &mp->is); cntcpy(&mp->right, &mp->is); cntcpy(&mp->in, &mp->is); } if (mp->left.n > mp->in.n) cntcpy(&mp->in, &mp->left); if (mp->right.n > mp->in.n) cntcpy(&mp->in, &mp->right); ++mp; }done: reg->mustn = result.n; for (i = 0; i < result.n; ++i) reg->must[i] = result.p[i];} :MPW:MPW Tools:Tools with Source:e?grep ƒ:dfa.h
/* dfa.h - declarations for GNU deterministic regexp compiler Copyright (C) 1988 Free Software Foundation, Inc. Written June, 1988 by Mike Haertel NO WARRANTY BECAUSE THIS PROGRAM IS LICENSED FREE OF CHARGE, WE PROVIDE ABSOLUTELYNO WARRANTY, TO THE EXTENT PERMITTED BY APPLICABLE STATE LAW. EXCEPTWHEN OTHERWISE STATED IN WRITING, FREE SOFTWARE FOUNDATION, INC,RICHARD M. STALLMAN AND/OR OTHER PARTIES PROVIDE THIS PROGRAM "AS IS"WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING,BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY ANDFITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITYAND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVEDEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR ORCORRECTION. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW WILL RICHARD M.STALLMAN, THE FREE SOFTWARE FOUNDATION, INC., AND/OR ANY OTHER PARTYWHO MAY MODIFY AND REDISTRIBUTE THIS PROGRAM AS PERMITTED BELOW, BELIABLE TO YOU FOR DAMAGES, INCLUDING ANY LOST PROFITS, LOST MONIES, OROTHER SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THEUSE OR INABILITY TO USE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA ORDATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY THIRD PARTIES ORA FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS) THISPROGRAM, EVEN IF YOU HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCHDAMAGES, OR FOR ANY CLAIM THER PARTY. GENERAL PUBLIC LICENSE TO COPY 1. You may copy and distribute verbatim copies of this source fileas you receive it, in any medium, provided that you conspicuously andappropriately publish on each copy a valid copyright notice "Copyright (C) 1988 Free Software Foundation, Inc."; and include following thecopyright notice a verbatim copy of the above disclaimer of warrantyand of this License. You may charge a distribution fee for thephysical act of transferring a copy. 2. You may modify your copy or copies of this source file orany portion of it, and copy and distribute such modifications underthe terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains or is a derivative of this program or any part thereof, to be licensed at no charge to all third parties on terms identical to those contained in this License Agreement (except that you may choose to grant more extensive warranty protection to some or all third parties, at your option). c) You may charge a distribution fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee.Mere aggregation of another unrelated program with this program (or itsderivative) on a volume of a storage or distribution medium does not bringthe other program under the scope of these terms. 3. You may copy and distribute this program or any portion of it incompiled, executable or object code form under the terms of Paragraphs1 and 2 above provided that you do the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal shipping charge) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.)For an executable file, complete source code means all the source code forall modules it contains; but, as a special exception, it need not includesource code for modules which are standard libraries that accompany theoperating system on which the executable file runs. 4. You may not copy, sublicense, distribute or transfer this programexcept as expressly provided under this License Agreement. Any attemptotherwise to copy, sublicense, distribute or transfer this program is void andyour rights to use the program under this License agreement shall beautomatically terminated. However, parties who have received computersoftware programs from you with this License Agreement will not havetheir licenses terminated so long as such parties remain in full compliance. 5. If you wish to incorporate parts of this program into other freeprograms whose distribution conditions are different, write to the FreeSoftware Foundation at 675 Mass Ave, Cambridge, MA 02139. We have not yetworked out a simple rule that can be stated here, but we will often permitthis. We will be guided by the two goals of preserving the free status ofall derivatives our free software and of promoting the sharing and reuse ofsoftware.In other words, you are welcome to use, share and improve this program.You are forbidden to forbid anyone else to use, share and improvewhat you give them. Help stamp out software-hoarding! *//* Prominent notice: This file modified 2/89 for MPW compatibility by Scott Lindsey, <scott@claris.com> */ /* #ifdef __STDC__ *//* Missing include files for GNU C. */#include <stdlib.h>/* typedef int size_t;extern void *calloc(int, size_t);extern void *malloc(size_t);extern void *realloc(void *, size_t);extern void free(void *);*//*#ifndef USGextern char *strchr(), *strrchr(), *memcpy();#elseextern char *index();#endif*/extern char *bcopy(), *bzero();#ifdef SOMEDAY#define ISALNUM(c) isalnum(c)#define ISALPHA(c) isalpha(c)#else#define ISALNUM(c) (isascii(c) && isalnum(c))#define ISALPHA(c) (isascii(c) && isalpha(c))#endif/* #else *//* ! __STDC__ *//*#define consttypedef int size_t;extern char *calloc(), *malloc(), *realloc();extern void free();#ifndef USGextern char *strchr(), *strrchr(), *memcpy();#elseextern char *index();#endifextern char *bcopy(), *bzero();#define ISALNUM(c) (isascii(c) && isalnum(c))#define ISALPHA(c) (isascii(c) && isalpha(c))#endif *//* ! __STDC__ *//* 1 means plain parentheses serve as grouping, and backslash parentheses are needed for literal searching. 0 means backslash-parentheses are grouping, and plain parentheses are for literal searching. */#define RE_NO_BK_PARENS 1/* 1 means plain | serves as the "or"-operator, and \| is a literal. 0 means \| serves as the "or"-operator, and | is a literal. */#define RE_NO_BK_VBAR 2/* 0 means plain + or ? serves as an operator, and \+, \? are literals. 1 means \+, \? are operators and plain +, ? are literals. */#define RE_BK_PLUS_QM 4/* 1 means | binds tighter than ^ or $. 0 means the contrary. */#define RE_TIGHT_VBAR 8/* 1 means treat \n as an _OR operator 0 means treat it as a normal character */#define RE_NEWLINE_OR 16/* 0 means that a special characters (such as *, ^, and $) always have their special meaning regardless of the surrounding context. 1 means that special characters may act as normal characters in some contexts. Specifically, this applies to: ^ - only special at the beginning, or after ( or | $ - only special at the end, or before ) or | *, +, ? - only special when not after the beginning, (, or | */#define RE_CONTEXT_INDEP_OPS 32/* Now define combinations of bits for the standard possibilities. */#define RE_SYNTAX_AWK (RE_NO_BK_PARENS | RE_NO_BK_VBAR | RE_CONTEXT_INDEP_OPS)#define RE_SYNTAX_EGREP (RE_SYNTAX_AWK | RE_NEWLINE_OR)#define RE_SYNTAX_GREP (RE_BK_PLUS_QM | RE_NEWLINE_OR)#define RE_SYNTAX_EMACS 0/* The NULL pointer. */#define NULL 0/* Number of bits in an unsigned char. */#define CHARBITS 8/* First integer value that is greater than any character code. */#define _NOTCHAR (1 << CHARBITS)/* INTBITS need not be exact, just a lower bound. */#define INTBITS (CHARBITS * sizeof (int))/* Number of ints required to hold a bit for every character. */#define _CHARSET_INTS ((_NOTCHAR + INTBITS - 1) / INTBITS)/* Sets of unsigned characters are stored as bit vectors in arrays of ints. */typedef int _charset[_CHARSET_INTS];/* The regexp is parsed into an array of tokens in postfix form. Some tokens are operators and others are terminal symbols. Most (but not all) of these codes are returned by the lexical analyzer. */#ifdef __STDC__typedef enum{ _END = -1, /* _END is a terminal symbol that matches the end of input; any value of _END or less in the parse tree is such a symbol. Accepting states of the DFA are those that would have a transition on _END. */ /* Ordinary character values are terminal symbols that match themselves. */ _EMPTY = _NOTCHAR, /* _EMPTY is a terminal symbol that matches the empty string. */ _BACKREF, /* _BACKREF is generated by \<digit>; it it not completely handled. If the scanner detects a transition on backref, it returns a kind of "semi-success" indicating that the match will have to be verified with a backtracking matcher. */ _BEGLINE, /* _BEGLINE is a terminal symbol that matches the empty string if it is at the beginning of a line. */ _ALLBEGLINE, /* _ALLBEGLINE is a terminal symbol that matches the empty string if it is at the beginning of a line; _ALLBEGLINE applies to the entire regexp and can only occur as the first token thereof. _ALLBEGLINE never appears in the parse tree; a _BEGLINE is prepended with _CAT to the entire regexp instead. */ _ENDLINE, /* _ENDLINE is a terminal symbol that matches the empty string if it is at the end of a line. */ _ALLENDLINE, /* _ALLENDLINE is to _ENDLINE as _ALLBEGLINE is to _BEGLINE. */ _BEGWORD, /* _BEGWORD is a terminal symbol that matches the empty string if it is at the beginning of a word. */ _ENDWORD, /* _ENDWORD is a terminal symbol that matches the empty string if it is at the end of a word. */ _LIMWORD, /* _LIMWORD is a terminal symbol that matches the empty string if it is at the beginning or the end of a word. */ _NOTLIMWORD, /* _NOTLIMWORD is a terminal symbol that matches the empty string if it is not at the beginning or end of a word. */ _QMARK, /* _QMARK is an operator of one argument that matches zero or one occurences of its argument. */ _STAR, /* _STAR is an operator of one argument that matches the Kleene closure (zero or more occurrences) of its argument. */ _PLUS, /* _PLUS is an operator of one argument that matches the positive closure (one or more occurrences) of its argument. */ _CAT, /* _CAT is an operator of two arguments that matches the concatenation of its arguments. _CAT is never returned by the lexical analyzer. */ _OR, /* _OR is an operator of two arguments that matches either of its arguments. */ _LPAREN, /* _LPAREN never appears in the parse tree, it is only a lexeme. */ _RPAREN, /* _RPAREN never appears in the parse tree. */ _SET /* _SET and (and any value greater) is a terminal symbol that matches any of a class of characters. */} _token;#else /* ! __STDC__ */typedef short _token;#define _END -1#define _EMPTY _NOTCHAR#define _BACKREF (_EMPTY + 1)#define _BEGLINE (_EMPTY + 2)#define _ALLBEGLINE (_EMPTY + 3)#define _ENDLINE (_EMPTY + 4)#define _ALLENDLINE (_EMPTY + 5)#define _BEGWORD (_EMPTY + 6)#define _ENDWORD (_EMPTY + 7)#define _LIMWORD (_EMPTY + 8)#define _NOTLIMWORD (_EMPTY + 9)#define _QMARK (_EMPTY + 10)#define _STAR (_EMPTY + 11)#define _PLUS (_EMPTY + 12)#define _CAT (_EMPTY + 13)#define _OR (_EMPTY + 14)#define _LPAREN (_EMPTY + 15)#define _RPAREN (_EMPTY + 16)#define _SET (_EMPTY + 17)#endif /* ! __STDC__ *//* Sets are stored in an array in the compiled regexp; the index of the array corresponding to a given set token is given by _SET_INDEX(t). */#define _SET_INDEX(t) ((t) - _SET)/* Sometimes characters can only be matched depending on the surrounding context. Such context decisions depend on what the previous character was, and the value of the current (lookahead) character. Context dependent constraints are encoded as 8 bit integers. Each bit that is set indicates that the constraint succeeds in the corresponding context. bit 7 - previous and current are newlines bit 6 - previous was newline, current isn't bit 5 - previous wasn't newline, current is bit 4 - neither previous nor current is a newline bit 3 - previous and current are word-constituents bit 2 - previous was word-constituent, current isn't bit 1 - previous wasn't word-constituent, current is bit 0 - neither previous nor current is word-constituent Word-constituent characters are those that satisfy isalnum(). The macro _SUCCEEDS_IN_CONTEXT determines whether a a given constraint succeeds in a particular context. Prevn is true if the previous character was a newline, currn is true if the lookahead character is a newline. Prevl and currl similarly depend upon whether the previous and current characters are word-constituent letters. */#define _MATCHES_NEWLINE_CONTEXT(constraint, prevn, currn) \ ((constraint) & 1 << ((prevn) ? 2 : 0) + ((currn) ? 1 : 0) + 4)#define _MATCHES_LETTER_CONTEXT(constraint, prevl, currl) \ ((constraint) & 1 << ((prevl) ? 2 : 0) + ((currl) ? 1 : 0))#define _SUCCEEDS_IN_CONTEXT(constraint, prevn, currn, prevl, currl) \ (_MATCHES_NEWLINE_CONTEXT(constraint, prevn, currn) \ && _MATCHES_LETTER_CONTEXT(constraint, prevl, currl))/* The following macros give information about what a constraint depends on. */#define _PREV_NEWLINE_DEPENDENT(constraint) \ (((constraint) & 0xc0) >> 2 != ((constraint) & 0x30))#define _PREV_LETTER_DEPENDENT(constraint) \ (((constraint) & 0x0c) >> 2 != ((constraint) & 0x03))/* Tokens that match the empty string subject to some constraint actually work by applying that constraint to determine what may follow them, taking into account what has gone before. The following values are the constraints corresponding to the special tokens previously defined. */#define _NO_CONSTRAINT 0xff#define _BEGLINE_CONSTRAINT 0xcf#define _ENDLINE_CONSTRAINT 0xaf#define _BEGWORD_CONSTRAINT 0xf2#define _ENDWORD_CONSTRAINT 0xf4#define _LIMWORD_CONSTRAINT 0xf6#define _NOTLIMWORD_CONSTRAINT 0xf9/* States of the recognizer correspond to sets of positions in the parse tree, together with the constraints under which they may be matched. So a position is encoded as an index into the parse tree together with a constraint. */typedef struct{ unsigned index:24, /* Index into the parse array. */ constraint:8; /* Constraint for matching this position. */} _position;/* Sets of positions are stored as arrays. */typedef struct{ _position *elems; /* Elements of this position set. */ int nelem; /* Number of elements in this set. */} _position_set;/* A state of the regexp consists of a set of positions, some flags, and the token value of the lowest-numbered position of the state that contains an _END token. */typedef struct{ int hash; /* Hash of the positions of this state. */ _position_set elems; /* Positions this state could match. */ unsigned newline:1, /* True if previous state matched newline. */ let
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:e?grep ƒ:dfa.h
+++++ Continued from previous card +++++
ter:1, /* True if previous state matched a letter. */ backref:1, /* True if this state matches a \<digit>. */ constraint:8; /* Constraint for this state to accept. */ int first_end; /* Token value of the first _END in elems. */} _dfa_state;/* If an r.e. is at most MUST_MAX characters long, we look for a string which must appear in it; whatever's found is dropped into the struct reg. */#define MUST_MAX 50/* A compiled regular expression. */struct regexp{ /* Stuff built by the scanner. */ _charset *charsets; /* Array of character sets for _SET tokens. */ int cindex; /* Index for adding new charsets. */ int calloc; /* Number of charsets currently allocated. */ /* Stuff built by the parser. */ _token *tokens; /* Postfix parse array. */ int tindex; /* Index for adding new tokens. */ int talloc; /* Number of tokens currently allocated. */ int depth; /* Depth required of an evaluation stack used for depth-first traversal of the parse tree. */ int nleaves; /* Number of leaves on the parse tree. */ int nregexps; /* Count of parallel regexps being built with regparse(). */ /* Stuff owned by the state builder. */ _dfa_state *states; /* States of the regexp. */ int sindex; /* Index for adding new states. */ int salloc; /* Number of states currently allocated. */ /* Stuff built by the structure analyzer. */ _position_set *follows; /* Array of follow sets, indexed by position index. The follow of a position is the set of positions containing characters that could conceivably follow a character matching the given position in a string matching the regexp. Allocated to the maximum possible position index. */ int searchflag; /* True if we are supposed to build a searching as opposed to an exact matcher. A searching matcher finds the first and shortest string matching a regexp anywhere in the buffer, whereas an exact matcher finds the longest string matching, but anchored to the beginning of the buffer. */ /* Stuff owned by the executor. */ int tralloc; /* Number of transition tables that have slots so far. */ int trcount; /* Number of transition tables that have actually been built. */ int **trans; /* Transition tables for states that can never accept. If the transitions for a state have not yet been computed, or the state could possibly accept, its entry in this table is NULL. */ int **realtrans; /* Trans always points to realtrans + 1; this is so trans[-1] can contain NULL. */ int **fails; /* Transition tables after failing to accept on a state that potentially could do so. */ int *success; /* Table of acceptance conditions used in regexecute and computed in build_state. */ int *newlines; /* Transitions on newlines. The entry for a newline in any transition table is always -1 so we can count lines without wasting too many cycles. The transition for a newline is stored separately and handled as a special case. Newline is also used as a sentinel at the end of the buffer. */ char must[MUST_MAX]; int mustn;};/* Some macros for user access to regexp internals. *//* ACCEPTING returns true if s could possibly be an accepting state of r. */#define ACCEPTING(s, r) ((r).states[s].constraint)/* ACCEPTS_IN_CONTEXT returns true if the given state accepts in the specified context. */#define ACCEPTS_IN_CONTEXT(prevn, currn, prevl, currl, state, reg) \ _SUCCEEDS_IN_CONTEXT((reg).states[state].constraint, \ prevn, currn, prevl, currl)/* FIRST_MATCHING_REGEXP returns the index number of the first of parallel regexps that a given state could accept. Parallel regexps are numbered starting at 1. */#define FIRST_MATCHING_REGEXP(state, reg) (-(reg).states[state].first_end)/* Entry points. */#ifdef __STDC__/* Regsyntax() takes two arguments; the first sets the syntax bits described earlier in this file, and the second sets the case-folding flag. */extern void regsyntax(int, int);/* Compile the given string of the given length into the given struct regexp. Final argument is a flag specifying whether to build a searching or an exact matcher. */extern void regcompile(const char *, size_t, struct regexp *, int);/* Execute the given struct regexp on the buffer of characters. The first char * points to the beginning, and the second points to the first character after the end of the buffer, which must be a writable place so a sentinel end-of-buffer marker can be stored there. The second-to-last argument is a flag telling whether to allow newlines to be part of a string matching the regexp. The next-to-last argument, if non-NULL, points to a place to increment every time we see a newline. The final argument, if non-NULL, points to a flag that will be set if further examination by a backtracking matcher is needed in order to verify backreferencing; otherwise the flag will be cleared. Returns NULL if no match is found, or a pointer to the first character after the first & shortest matching string in the buffer. */extern char *regexecute(struct regexp *, char *, char *, int, int *, int *);/* Free the storage held by the components of a struct regexp. */extern void regfree(struct regexp *);/* Entry points for people who know what they're doing. *//* Initialize the components of a struct regexp. */extern void reginit(struct regexp *);/* Incrementally parse a string of given length into a struct regexp. */extern void regparse(const char *, size_t, struct regexp *);/* Analyze a parsed regexp; second argument tells whether to build a searching or an exact matcher. */extern void reganalyze(struct regexp *, int);/* Compute, for each possible character, the transitions out of a given state, storing them in an array of integers. */extern void regstate(int, struct regexp *, int []);/* Error handling. *//* Regerror() is called by the regexp routines whenever an error occurs. It takes a single argument, a NUL-terminated string describing the error. The default regerror() prints the error message to stderr and exits. The user can provide a different regfree() if so desired. */extern void regerror(const char *);#else /* ! __STDC__ */extern void regsyntax(), regcompile(), regfree(), reginit(), regparse();extern void reganalyze(), regstate(), regerror();extern char *regexecute();#endif :MPW:MPW Tools:Tools with Source:e?grep ƒ:getopt.c
/* Getopt for GNU. Copyright (C) 1987 Free Software Foundation, Inc. NO WARRANTY BECAUSE THIS PROGRAM IS LICENSED FREE OF CHARGE, WE PROVIDE ABSOLUTELYNO WARRANTY, TO THE EXTENT PERMITTED BY APPLICABLE STATE LAW. EXCEPTWHEN OTHERWISE STATED IN WRITING, FREE SOFTWARE FOUNDATION, INC,RICHARD M. STALLMAN AND/OR OTHER PARTIES PROVIDE THIS PROGRAM "AS IS"WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING,BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY ANDFITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITYAND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVEDEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR ORCORRECTION. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW WILL RICHARD M.STALLMAN, THE FREE SOFTWARE FOUNDATION, INC., AND/OR ANY OTHER PARTYWHO MAY MODIFY AND REDISTRIBUTE THIS PROGRAM AS PERMITTED BELOW, BELIABLE TO YOU FOR DAMAGES, INCLUDING ANY LOST PROFITS, LOST MONIES, OROTHER SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THEUSE OR INABILITY TO USE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA ORDATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY THIRD PARTIES ORA FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS) THISPROGRAM, EVEN IF YOU HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCHDAMAGES, OR FOR ANY CLAIM BY ANY OTHER PARTY. GENERAL PUBLIC LICENSE TO COPY 1. You may copy and distribute verbatim copies of this source fileas you receive it, in any medium, provided that you conspicuously andappropriately publish on eaa valid copyright notice "Copyright (C) 1987 Free Software Foundation, Inc."; and include following thecopyright notice a verbatim copy of the above disclaimer of warrantyand of this License. You may charge a distribution fee for thephysical act of transferring a copy. 2. You may modify your copy or copies of this source file orany portion of it, and copy and distribute such modifications underthe terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains or is a derivative of this program or any part thereof, to be licensed at no charge to all third parties on terms identical to those contained in this License Agreement (except that you may choose to grant more extensive warranty protection to third parties, at your option). c) You may charge a distribution fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 3. You may copy and distribute this program or any portion of it incompiled, executable or object code form under the terms of Paragraphs1 and 2 above provided that you do the following: a) cause each such copy to be accompanied by the corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) cause each such copy to be accompanied by a written offer, with no time limit, to give any third party free (except for a nominal shipping charge) a machine readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) in the case of a recipient of this program in compiled, executable or object code form (without the corresponding source code) you shall cause copies you distribute to be accompanied by a copy of the written offer of source code which you received along with the copy you received. 4. You may not copy, sublicense, distribute or transfer this programexcept as expressly provided under this License Agreement. Any attemptotherwise to copy, sublicense, distribute or transfer this program is void andyour rights to use the program under this License agreement shall beautomatically terminated. However, parties who have received computersoftware programs from you with this License Agreement will not havetheir licenses terminated so long as such parties remain in full compliance. 5. If you wish to incorporate parts of this program into other freeprograms whose distribution conditions are different, write to the FreeSoftware Foundation at 675 Mass Ave, Cambridge, MA 02139. We have not yetworked out a simple rule that can be stated here, but we will often permitthis. We will be guided by the two goals of preserving the free status ofall derivatives of our free software and of promoting the sharing and reuse ofsoftware.In other words, you are welcome to use, share and improve this program.You are forbidden to forbid anyone else to use, share and improvewhat you give them. Help stamp out software-hoarding! *//* Prominent notice: This file modified 2/89 for MPW compatibility by Scott Lindsey, <scott@claris.com> */ /* This version of `getopt' appears to the caller like standard Unix `getopt' but it behaves differently for the user, since it allows the user to intersperse the options with the other arguments. As `getopt' works, it permutes the elements of `argv' so that, when it is done, all the options precede everything else. Thus all application programs are extended to handle flexible argument order. Setting the environment variable _POSIX_OPTION_ORDER disables permutation. Then the behavior is completely standard. GNU application programs can use a third alternative mode in which they can distinguish the relative order of options and other arguments. */#include <stdio.h>#include <string.h>#ifdef sparc#include <alloca.h>#endif#ifdef USG#define bcopy(s, d, l) memcpy((d), (s), (l))#endif/* For communication from `getopt' to the caller. When `getopt' finds an option that takes an argument, the argument value is returned here. Also, when `ordering' is RETURN_IN_ORDER, each non-option ARGV-element is returned here. */char *optarg = 0;/* Index in ARGV of the next element to be scanned. This is used for communication to and from the caller and for communication between successive calls to `getopt'. On entry to `getopt', zero means this is the first call; initialize. When `getopt' returns EOF, this is the index of the first of the non-option elements that the caller should itself scan. Otherwise, `optind' communicates from one call to the next how much of ARGV has been scanned so far. */int optind = 0;/* The next char to be scanned in the option-element in which the last option character we returned was found. This allows us to pick up the scan where we left off. If this is zero, or a null string, it means resume the scan by advancing to the next ARGV-element. */static char *nextchar;/* Callers store zero here to inhibit the error message for unrecognized options. */int opterr = 1;/* Describe how to deal with options that follow non-option ARGV-elements. UNSPECIFIED means the caller did not specify anything; the default is then REQUIRE_ORDER if the environment variable _OPTIONS_FIRST is defined, PERMUTE otherwise. REQUIRE_ORDER means don't recognize them as options. Stop option processing when the first non-option is seen. This is what Unix does. PERMUTE is the default. We permute the contents of `argv' as we scan, so that eventually all the options are at the end. This allows options to be given in any order, even with programs that were not written to expect this. RETURN_IN_ORDER is an option available to programs that were written to expect options and other ARGV-elements in any order and that care about the ordering of the two. We describe each non-option ARGV-element as if it were the argument of an option with character code zero. Using `-' as the first character of the list of option characters requests this mode of operation. The special argument `--' forces an end of option-scanning regardless of the value of `ordering'. In the case of RETURN_IN_ORDER, only `--' can cause `getopt' to return EOF with `optind' != ARGC. */static enum { REQUIRE_ORDER, PERMUTE, RETURN_IN_ORDER } ordering; /* Handle permutation of arguments. *//* Describe the part of ARGV that contains non-options that have been skipped. `first_nonopt' is the index in ARGV of the first of them; `last_nonopt' is the index after the last of them. */static int first_nonopt;static int last_nonopt;/* Exchange two adjacent subsequences of ARGV. One subsequence is elements [first_nonopt,last_nonopt) which contains all the non-options that have been skipped so far. The other is elements [last_nonopt,optind), which contains all the options processed since those non-options were skipped. `first_nonopt' and `last_nonopt' are relocated so that they describe the new indices of the non-options in ARGV after they are moved. */static voidexchange (argv) char **argv;{ int nonopts_size = (last_nonopt - first_nonopt) * sizeof (char *); char **temp = (char **) alloca (nonopts_size); /* Interchange the two blocks of data in argv. */ bcopy (&argv[first_nonopt], temp, nonopts_size); bcopy (&argv[last_nonopt], &argv[first_nonopt], (optind - last_nonopt) * sizeof (char *)); bcopy (temp, &argv[first_nonopt + optind - last_nonopt], nonopts_size); /* Update records for the slots the non-options now occupy. */ first_nonopt += (optind - last_nonopt); last_nonopt = optind;} /* Scan elements of ARGV (whose length is ARGC) for option characters given in OPTSTRING. If an element of ARGV starts with '-', and is not exactly "-" or "--", then it is an option element. The characters of this element (aside from the initial '-') are option characters. If `getopt' is called repeatedly, it returns successively each of theoption characters from each of the option elements. If `getopt' finds another option character, it returns that character, updating `optind' and `nextchar' so that the next call to `getopt' can resume the scan with the following option character or ARGV-element. If there are no more option characters, `getopt' returns `EOF'. Then `optind' is the index in ARGV of the first ARGV-element that is not an option. (The ARGV-elements have been permuted so that those that are not options now come last.) OPTSTRING is a string containing the legitimate option characters. A colon in OPTSTRING means that the previous character is an option that wants an argument. The argument is taken from the rest of the current ARGV-element, or from the following ARGV-element, and returned in `optarg'. If an option character is seen that is not listed in OPTSTRING, return '?' after printing an error message. If you set `opterr' to zero, the error message is suppressed but we still return '?'. If a char in OPTSTRING is followed by a colon, that means it wants an arg, so the following text in the same ARGV-element, or the text of the following ARGV-element, is returned in `optarg. Two colons mean an option that wants an optional arg; if there is text in the current ARGV-element, it is returned in `optarg'. If OPTSTRING starts with `-', it requests a different method of handling the non-option ARGV-elements. See the comments about RETURN_IN_ORDER, above. */intgetopt (argc, argv, optstring) int argc; char **argv; char *optstring;{ /* Initialize the internal data when the first call is made. Start processing options with ARGV-element 1 (since ARGV-element 0 is the program name); the sequence of previously skipped non-option ARGV-elements is empty. */ if (optind == 0) { first_nonopt = last_nonopt = optind = 1; nextchar = 0; /* Determine how to handle the ordering of options and nonoptions. */ if (optstring[0] == '-') ordering = RETURN_IN_ORDER; else if (getenv ("_POSIX_OPTION_ORDER") != 0) ordering = REQUIRE_ORDER; else ordering = PERMUTE; } if (nextchar == 0 || *nextchar == 0) { if (ordering == PERMUTE) { /* If we have just processed some options following some non-options, exchange them so that the options come first. */ if (first_nonopt != last_nonopt && last_nonopt != optind) exchange (argv); else if (last_nonopt != optind) first_nonopt = optind; /* Now skip any additional non-options and extend the range of non-options previously skipped. */ while (optind < argc && (argv[optind][0] != '-' || argv[optind][1] == 0)) optind++; last_nonopt = optind; } /* Special ARGV-element `--' means premature end of options. Skip it like a null option, then exchange with previous non-options as if it were an option, then skip everything else like a non-option. */ if (optind != argc && !strcmp (argv[optind], "--")) { optind++; if (first_nonopt != last_nonopt && last_nonopt != optind) exchange (argv); else if (first_nonopt == last_nonopt) first_nonopt = optind; last_nonopt = argc; optind = argc; } /* If we have done all the ARGV-elements, stop the scan and back over any non-options that we skipped and permuted. */ if (optind == argc) { /* Set the next-arg-index to point at the non-options that we previously skipped, so the caller will digest them. */ if (first_nonopt != last_nonopt) optind = first_nonopt; return EOF; } /* If we have come to a non-option and did not permute it, either stop the scan or describe it to the caller and pass it by. */ if (argv[optind][0] != '-' || argv[optind][1] == 0) { if (ordering == REQUIRE_ORDER) return EOF; optarg = argv[optind++]; return 0; } /* We have found another option-ARGV-element. Start decoding its characters. */ nextchar = argv[optind] + 1; } /* Look at and handle the next option-character. */ { char c = *nextchar++; char *temp = (char *) index (optstring, c); /* Increment `optind' when we start to process its last character. */ if (*nextchar == 0) optind++; if (temp == 0 || c == ':') { if (opterr != 0) { if (c < 040 || c >= 0177) fprintf (stderr, "%s: unrecognized option, character code 0%o\n", argv[0], c); else fprintf (stderr, "%s: unrecognized option `-%c'\n", argv[0], c); } return '?'; } if (temp[1] == ':') { if (temp[2] == ':') { /* This is an option that accepts an argument optionally. */ if (*nextchar != 0) { optarg = nextchar; optind++; } else optarg = 0; nextchar = 0; } else { /* This is an option that requires an argument. */ if (*nextchar != 0) { optarg = nextchar; /* If we end this ARGV-element by taking the rest as an arg, we must advance to the next element now. */ optind++; } else if (optind == argc) { if (opterr != 0) fprintf (stderr, "%s: no argument for `-%c' option\n", argv[0], c); optarg = 0; } else /* We already incremented `optind' once; increment it again when taking next ARGV-elt as argument. */ optarg = argv[optind++]; nextchar = 0; } } return c; }} #ifdef TEST/* Compile with -DTEST to make an executable for use in testing the above definition of `getopt'. */intmain (argc, argv) int argc; char **argv;{ char c; int digit_optind = 0; while (1) { int this_option_optind = optind; if ((c = getopt (argc, argv, "abc:d:0123456789")) == EOF) break; switch (c) {
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:e?grep ƒ:getopt.c
+++++ Continued from previous card +++++
case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': if (digit_optind != 0 && digit_optind != this_option_optind) printf ("digits occur in two different argv-elements.\n"); digit_optind = this_option_optind; printf ("option %c\n", c); break; case 'a': printf ("option a\n"); break; case 'b': printf ("option b\n"); break; case 'c': printf ("option c with value `%s'\n", optarg); break; case '?': break; default: printf ("?? getopt returned character code 0%o ??\n", c); } } if (optind < argc) { printf ("non-option ARGV-elements: "); while (optind < argc) printf ("%s ", argv[optind++]); printf ("\n"); } return 0;}#endif /* TEST */ :MPW:MPW Tools:Tools with Source:e?grep ƒ:grep.c
/* grep - print lines matching an extended regular expression Copyright (C) 1988 Free Software Foundation, Inc. Written June, 1988 by Mike Haertel BMG speedups added July, 1988 by James A. Woods and Arthur David Olson NO WARRANTY BECAUSE THIS PROGRAM IS LICENSED FREE OF CHARGE, WE PROVIDE ABSOLUTELYNO WARRANTY, TO THE EXTENT PERMITTED BY APPLICABLE STATE LAW. EXCEPTWHEN OTHERWISE STATED IN WRITING, FREE SOFTWARE FOUNDATION, INC,RICHARD M. STALLMAN AND/OR OTHER PARTIES PROVIDE THIS PROGRAM "AS IS"WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING,BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY ANDFITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITYAND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVEDEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR ORCORRECTION. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW WILL RICHARD M.STALLMAN, THE FREE SOFTWARE FOUNDATION, INC., AND/OR ANY OTHER PARTYWHO MAY MODIFY AND REDISTRIBUTE THIS PROGRAM AS PERMITTED BELOW, BELIABLE TO YOU FOR DAMAGES, INCLUDING ANY LOST PROFITS, LOST MONIES, OROTHER SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THEUSE OR INABILITY TO USE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA ORDATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY THIRD PARTIES ORA FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS) THISPROGRAM, EVEN IF YOU HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCHDAMAGES, OR FOR ANY CLAIM BY ANY OTHER PARTY. GENERAL PUBLIC LICENSE TO COPY 1. You may copy and distribute verbatim copies of this source fileas you receive it, in any medium, provided that you conspicuously andappropriately publish on each copy a valid copyright notice "Copyright (C) 1988 Free Software Foundation, Inc."; and include following thecopyright notice a verbatim copy of the above disclaimer of warrantyand of this License. You may charge a distribution fee for thephysical act of transferring a copy. 2. You may modify your copy or copies of this source file orany portion of it, and copy and distribute such modifications underthe terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains or is a derivative of this program or any part thereof, to be licensed at no charge to all third parties on terms identical to those contained in this License Agreement (except that you may choose to grant more extensive warranty protection to some or all third parties, at your option). c) You may charge a distribution fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee.Mere aggregation of another unrelated program with this program (or itsderivative) on a volume of a storage or distribution medium does not bringthe other program under the scope of these terms. 3. You may copy and distribute this program or any portion of it incompiled, executable or object code form under the terms of Paragraphs1 and 2 above provided that you do the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal shipping charge) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.)For an executable file, complete source code means all the source code forall modules it contains; but, as a special exception, it need not includesource code for modules which are standard libraries that accompany theoperating system on which the executable file runs. 4. You may not copy, sublicense, distribute or transfer this programexcept as expressly provided under this License Agreement. Any attemptotherwise to copy, sublicense, distribute or transfer this program is void andyour rights to use the program under this License agreement shall beautomatically terminated. However, parties who have received computersoftware programs from you with this License Agreement will not havetheir licenses terminated so long as such parties remain in full compliance. 5. If you wish to incorporate parts of this program into other freeprograms whose distribution conditions are different, write to the FreeSoftware Foundation at 675 Mass Ave, Cambridge, MA 02139. We have not yetworked out a simple rule that can be stated here, but we will often permitthis. We will be guided by the two goals of preserving the free status ofall derivatives our free software and of promoting the sharing and reuse ofsoftware.In other words, you are welcome to use, share and improve this program.You are forbidden to forbid anyone else to use, share and improvewhat you give them. Help stamp out software-hoarding! *//* Prominent notice: This file modified 2/89 for MPW compatibility by Scott Lindsey, <scott@claris.com> */ #include <ctype.h>#include <stdio.h>#ifdef USG#include <memory.h>#include <string.h>#else#include <strings.h>#endif#include "dfa.h"#include "regex.h"#ifdef __STDC__extern getopt(int, char **, const char *);extern read(int, void *, int);extern open(const char *, int, ...);extern void close();#elseextern char *strrchr();#endifextern char *optarg;extern optind, opterr;extern errno;extern char *sys_errlist[];#define MAX(a, b) ((a) > (b) ? (a) : (b))/* Exit status codes. */#define MATCHES_FOUND 0 /* Exit 0 if no errors and matches found. */#define NO_MATCHES_FOUND 1 /* Exit 1 if no matches were found. */#define ERROR 2 /* Exit 2 if some error occurred. *//* Error is set true if something awful happened. */static int error;/* The program name for error messages. */static char *prog;/* We do all our own buffering by hand for efficiency. */static char *buffer; /* The buffer itself, grown as needed. */static bufbytes; /* Number of bytes in the buffer. */static size_t bufalloc; /* Number of bytes allocated to the buffer. */static bufprev; /* Number of bytes that have been forgotten. This is used to get byte offsets from the beginning of the file. */static bufread; /* Number of bytes to get with each read(). */static voidinitialize_buffer(){ bufread = 8192; bufalloc = bufread + bufread / 2; buffer = malloc(bufalloc); if (! buffer) { fprintf(stderr, "%s: Memory exhausted (%s)\n", prog, sys_errlist[errno]); exit(ERROR); }}/* The current input file. */static fd;static char *filename;static eof;/* Fill the buffer retaining the last n bytes at the beginning of the newly filled buffer (for backward context). Returns the number of new bytes read from disk. */staticfill_buffer_retaining(n) int n;{ char *p, *q; int i; /* See if we need to grow the buffer. */ if (bufalloc - n <= bufread) { while (bufalloc - n <= bufread) { bufalloc *= 2; bufread *= 2; } buffer = realloc(buffer, bufalloc); if (! buffer) { fprintf(stderr, "%s: Memory exhausted (%s)\n", prog, sys_errlist[errno]); exit(ERROR); } } bufprev += bufbytes - n; /* Shift stuff down. */ for (i = n, p = buffer, q = p + bufbytes - n; i--; ) *p++ = *q++; bufbytes = n; if (eof) return 0; /* Read in new stuff. */ i = read(fd, buffer + bufbytes, bufread); if (i < 0) { fprintf(stderr, "%s: read on %s failed (%s)\n", prog, filename ? filename : "<stdin>", sys_errlist[errno]); error = 1; } /* Kludge to pretend every nonempty file ends with a newline. */ if (i == 0 && bufbytes > 0 && buffer[bufbytes - 1] != '\n') { eof = i = 1; buffer[bufbytes] = '\n'; } bufbytes += i; return i;} /* Various flags set according to the argument switches. */static trailing_context; /* Lines of context to show after matches. */static leading_context; /* Lines of context to show before matches. */static byte_count; /* Precede output lines the byte count of the first character on the line. */static no_filenames; /* Do not display filenames. */static line_numbers; /* Precede output lines with line numbers. */static silent; /* Produce no output at all. This switch is bogus, ever hear of /dev/null? */static nonmatching_lines; /* Print lines that don't match the regexp. */static bmgexec; /* Invoke Boyer-Moore-Gosper routines *//* The compiled regular expression lives here. */static struct regexp reg;/* The compiled regular expression for the backtracking matcher lives here. */static struct re_pattern_buffer regex;/* Pointer in the buffer after the last character printed. */static char *printed_limit;/* True when printed_limit has been artifically advanced without printing anything. */static int printed_limit_fake;/* Print a line at the given line number, returning the number of characters actually printed. Matching is true if the line is to be considered a "matching line". This is only meaningful if surrounding context is turned on. */staticprint_line(p, number, matching) char *p; int number; int matching;{ int count = 0; if (silent) { do ++count; while (*p++ != '\n'); printed_limit_fake = 0; printed_limit = p; return count; } if (filename && !no_filenames) printf("File \"%s\"%c", filename, matching ? ';' : '-'); if (byte_count) printf("Byte %d %c", p - buffer + bufprev, matching ? '#' : '-'); if (line_numbers) printf("Line %d %c", number, matching ? '#' : '-'); do { ++count; putchar(*p); } while (*p++ != '\n'); printed_limit_fake = 0; printed_limit = p; return count;}/* Print matching or nonmatching lines from the current file. Returns a count of matching or nonmatching lines. */staticgrep(){ int retain = 0; /* Number of bytes to retain on next call to fill_buffer_retaining(). */ char *search_limit; /* Pointer to the character after the last newline in the buffer. */ char saved_char; /* Character after the last newline. */ char *resume; /* Pointer to where to resume search. */ int resume_index = 0; /* Count of characters to ignore after refilling the buffer. */ int line_count = 1; /* Line number. */ int try_backref; /* Set to true if we need to verify the match with a backtracking matcher. */ int initial_line_count; /* Line count at beginning of last search. */ char *match; /* Pointer to the first character after the string matching the regexp. */ int match_count = 0; /* Count of matching lines. */ char *matching_line; /* Pointer to first character of the matching line, or of the first line of context to print if context is turned on. */ char *real_matching_line; /* Pointer to the first character of the real matching line. */ char *next_line; /* Pointer to first character of the line following the matching line. */ int pending_lines = 0; /* Lines of context left over from last match that we have to print. */ static first_match = 1; /* True when nothing has been printed. */ int i; char *tmp; char *execute(); printed_limit_fake = 0; while (fill_buffer_retaining(retain) > 0) { /* Find the last newline in the buffer. */ search_limit = buffer + bufbytes; while (search_limit > buffer && search_limit[-1] != '\n') --search_limit; if (search_limit == buffer) { retain = bufbytes; continue; } /* Save the character after the last newline so regexecute can write its own sentinel newline. */ saved_char = *search_limit; /* Search the buffer for a match. */ printed_limit = buffer; resume = buffer + resume_index; initial_line_count = line_count; while (match = execute(®, resume, search_limit, 0, &line_count, &try_backref)) { ++match_count; /* Find the beginning of the matching line. */ matching_line = match; while (matching_line > resume && matching_line[-1] != '\n') --matching_line; real_matching_line = matching_line; /* Find the beginning of the next line. */ next_line = match; while (next_line < search_limit && *next_line++ != '\n') ; /* If a potential backreference is indicated, try it out with a backtracking matcher to make sure the line is a match. */ if (try_backref && re_search(®ex, matching_line, next_line - matching_line, 0, next_line - matching_line, NULL) < 0) { resume = next_line; if (resume == search_limit) break; else continue; } /* Print leftover lines from last time. If nonmatchs is turned on, print these as if they were matching lines. */ while (resume < matching_line && pending_lines) { resume += print_line(resume, initial_line_count++, nonmatching_lines); --pending_lines; } /* Print out the matching or nonmatching lines as necessary. */ if (! nonmatching_lines) { /* Back up over leading context if necessary. */ for (i = leading_context; matching_line > printed_limit && i; --i) { while (matching_line > printed_limit && (--matching_line)[-1] != '\n') ; --line_count; } /* If context is enabled, we may have to print a separator. */ if ((leading_context || trailing_context) && !silent && !first_match && (printed_limit_fake || matching_line > printed_limit)) printf("----------\n"); first_match = 0; /* Print the matching line and its leading context. */ while (matching_line < real_matching_line) matching_line += print_line(matching_line, line_count++, 0); matching_line += print_line(matching_line, line_count++, 1); /* If there's trailing context, leave some lines pending until next time. */ pending_lines = trailing_context; } else if (matching_line > resume) { char *real_resume = resume; /* Back up over leading context if necessary. */ for (i = leading_context; resume > printed_limit && i; --i) { while (resume > printed_limit && (--resume)[-1] != '\n') ; --initial_line_count; } /* If context is enabled, we may have to print a separator. */ if ((leading_context || trailing_context) && !silent && !first_match && (printed_limit_fake || resume > printed_limit)) printf("----------\n"); first_match = 0; /* Print out the presumably matching leading context. */ while (resume < real_resume) resume += print_line(resume, initial_line_count++, 0); /* Print out the nonmatching lines prior to the matching line. */ while (resume < matching_line) resume += print_line(resume, initial_line_count++, 1); /* Deal with trailing context. */ if (trailing_context) { print_line(matching_line, line_count, 0); pending_lines = trailing_context - 1; } /* Count the current line. */ ++line_count; } else { /* The line immediately after a matching line has to be printed because it was pend
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:e?grep ƒ:grep.c
+++++ Continued from previous card +++++
ing. */ if (pending_lines > 0) { --pending_lines; print_line(matching_line, line_count, 0); } ++line_count; } /* Resume searching at the beginning of the next line. */ initial_line_count = line_count; resume = next_line; if (resume == search_limit) break; } /* Restore the saved character. */ *search_limit = saved_char; if (! nonmatching_lines) { while (resume < search_limit && pending_lines) { resume += print_line(resume, initial_line_count++, 0); --pending_lines; } } else if (search_limit > resume) { char *initial_resume = resume; /* Back up over leading context if necessary. */ for (i = leading_context; resume > printed_limit && i; --i) { while (resume > printed_limit && (--resume)[-1] != '\n') ; --initial_line_count; } /* If context is enabled, we may have to print a separator. */ if ((leading_context || trailing_context) && !silent && !first_match && (printed_limit_fake || resume > printed_limit)) printf("----------\n"); first_match = 0; /* Print out all the nonmatching lines up to the search limit. */ while (resume < initial_resume) resume += print_line(resume, initial_line_count++, 0); while (resume < search_limit) resume += print_line(resume, initial_line_count++, 1); pending_lines = trailing_context; resume_index = 0; retain = bufbytes - (search_limit - buffer); continue; } /* Save the trailing end of the buffer for possible use as leading context in the future. */ i = leading_context; tmp = search_limit; while (tmp > printed_limit && i--) while (tmp > printed_limit && (--tmp)[-1] != '\n') ; resume_index = search_limit - tmp; retain = bufbytes - (tmp - buffer); if (tmp > printed_limit) printed_limit_fake = 1; } return nonmatching_lines ? line_count - match_count : match_count;} voidusage_and_die(){ fprintf(stderr,"usage: %s [-CVbchilnsvwx] [-<num>] [-AB <num>] [-f file] [-e] expr [files]\n", prog); exit(ERROR);}static char version[] = "GNU e?grep, version 1.2";main(argc, argv) int argc; char **argv;{ int c; int ignore_case = 0; /* Compile the regexp to ignore case. */ char *the_regexp = 0; /* The regular expression. */ int regexp_len; /* Length of the regular expression. */ char *regexp_file = 0; /* File containing parallel regexps. */ int count_lines = 0; /* Display only a count of matching lines. */ int list_files = 0; /* Display only the names of matching files. */ int whole_word = 0; /* Insist that the regexp match a word only. */ int whole_line = 0; /* Insist on matching only whole lines. */ int line_count = 0; /* Count of matching lines for a file. */ int matches_found = 0; /* True if matches were found. */ char *regex_errmesg; /* Error message from regex routines. */ char translate[_NOTCHAR]; /* Translate table for case conversion (needed by the backtracking matcher). */ if (prog = strrchr(argv[0], '/')) ++prog; else prog = argv[0]; opterr = 0; while ((c = getopt(argc, argv, "0123456789A:B:CVbce:f:hilnsvwx")) != EOF) switch (c) { case '?': usage_and_die(); break; case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': trailing_context = 10 * trailing_context + c - '0'; leading_context = 10 * leading_context + c - '0'; break; case 'A': if (! sscanf(optarg, "%d", &trailing_context) || trailing_context < 0) usage_and_die(); break; case 'B': if (! sscanf(optarg, "%d", &leading_context) || leading_context < 0) usage_and_die(); break; case 'C': trailing_context = leading_context = 2; break; case 'V': fprintf(stderr, "%s\n", version); break; case 'b': byte_count = 1; break; case 'c': count_lines = 1; silent = 1; break; case 'e': /* It doesn't make sense to mix -f and -e. */ if (regexp_file) usage_and_die(); the_regexp = optarg; break; case 'f': /* It doesn't make sense to mix -f and -e. */ if (the_regexp) usage_and_die(); regexp_file = optarg; break; case 'h': no_filenames = 1; break; case 'i': ignore_case = 1; for (c = 0; c < _NOTCHAR; ++c) if (isupper(c)) translate[c] = tolower(c); else translate[c] = c; regex.translate = translate; break; case 'l': list_files = 1; silent = 1; break; case 'n': line_numbers = 1; break; case 's': silent = 1; break; case 'v': nonmatching_lines = 1; break; case 'w': whole_word = 1; break; case 'x': whole_line = 1; break; default: /* This can't happen. */ fprintf(stderr, "%s: getopt(3) let one by!\n", prog); usage_and_die(); break; } /* Set the syntax depending on arg 0 and whether to ignore case. */ if (*prog == 'e') { regsyntax(RE_SYNTAX_EGREP, ignore_case); re_set_syntax(RE_SYNTAX_EGREP); } else { regsyntax(RE_SYNTAX_GREP, ignore_case); re_set_syntax(RE_SYNTAX_GREP); } /* Compile the regexp according to all the options. */ if (regexp_file) { FILE *fp = fopen(regexp_file, "r"); int len = 256; int i = 0; if (! fp) { fprintf(stderr, "%s: %s: %s\n", prog, regexp_file, sys_errlist[errno]); exit(ERROR); } the_regexp = malloc(len); while ((c = getc(fp)) != EOF) { the_regexp[i++] = c /* (c=='\r') ? '\n' : c */; if (i == len) the_regexp = realloc(the_regexp, len *= 2); } /* Nuke the concluding newline so we won't match the empty string. */ if (i > 0 && the_regexp[i - 1] == '\n') --i; regexp_len = i; } else if (! the_regexp) { if (optind >= argc) usage_and_die(); the_regexp = argv[optind++]; regexp_len = strlen(the_regexp); } else regexp_len = strlen(the_regexp); if (whole_word || whole_line) { char *n = malloc(regexp_len + 8); int i = 0; if (whole_line) n[i++] = 0xA5; else n[i++] = 0xB6, n[i++] = '<'; if (*prog != 'e') n[i++] = 0xB6; n[i++] = '('; memcpy(n + i, the_regexp, regexp_len); i += regexp_len; if (*prog != 'e') n[i++] = 0xB6; n[i++] = ')'; if (whole_line) n[i++] = 0xB0; else n[i++] = 0xB6, n[i++] = '>'; the_regexp = n; regexp_len = i; } regcompile(the_regexp, regexp_len, ®, 1); if (regex_errmesg = re_compile_pattern(the_regexp, regexp_len, ®ex)) regerror(regex_errmesg); /* Find the longest metacharacter-free string which must occur in the regexpr, before short-circuiting regexecute() with Boyer-Moore-Gosper. (Conjecture: The problem in general is NP-complete.) If there is no such string (like for many alternations), then default to full automaton search. regmust() code and heuristics [see dfa.c] courtesy Arthur David Olson. */ if (line_numbers == 0 && nonmatching_lines == 0) { if (reg.mustn == 0 || reg.mustn == MUST_MAX || strchr(reg.must, '\0') != reg.must + reg.mustn) bmgexec = 0; else { reg.must[reg.mustn] = '\0'; if (getenv("MUSTDEBUG") != NULL) (void) printf("must have: \"%s\"\n", reg.must); bmg_setup(reg.must, ignore_case); bmgexec = 1; } } if (argc - optind < 2) no_filenames = 1; initialize_buffer(); if (argc > optind) while (optind < argc) { bufprev = eof = 0; filename = argv[optind++]; fd = open(filename, 0, 0); if (fd < 0) { fprintf(stderr, "%s: %s: %s\n", prog, filename, sys_errlist[errno]); error = 1; continue; } if (line_count = grep()) matches_found = 1; close(fd); if (count_lines) if (!no_filenames) printf("%s:%d\n", filename, line_count); else printf("%d\n", line_count); else if (list_files && line_count) printf("%s\n", filename); } else { if (line_count = grep()) matches_found = 1; if (count_lines) printf("%d\n", line_count); else if (list_files && line_count) printf("<stdin>\n"); } if (error) exit(ERROR); if (matches_found) exit(MATCHES_FOUND); exit(NO_MATCHES_FOUND);}/* Needed by the regexp routines. This could be fancier, especially when dealing with parallel regexps in files. */voidregerror(s) const char *s;{ fprintf(stderr, "%s: %s\n", prog, s); exit(ERROR);}/* bmg_setup() and bmg_search() adapted from: Boyer/Moore/Gosper-assisted 'egrep' search, with delta0 table as in original paper (CACM, October, 1977). No delta1 or delta2. According to experiment (Horspool, Soft. Prac. Exp., 1982), delta2 is of minimal practical value. However, to improve for worst case input, integrating the improved Galil strategies (Apostolico/Giancarlo, Siam. J. Comput., February 1986) deserves consideration. James A. Woods Copyleft (C) 1986, 1988 NASA Ames Research Center*/char *execute(r, begin, end, newline, count, try_backref) struct regexp *r; char *begin; char *end; int newline; int *count; int *try_backref;{ register char *p, *s; char *match; char *start = begin; char save; /* regexecute() sentinel */ int len; char *bmg_search(); if (!bmgexec) /* full automaton search */ return(regexecute(r, begin, end, newline, count, try_backref)); else { len = end - begin; while ((match = bmg_search((unsigned char *) start, len)) != NULL) { p = match; /* narrow search range to submatch line */ while (p > begin && *p != '\n') p--; s = match; while (s < end && *s != '\n') s++; s++; save = *s; *s = '\0'; match = regexecute(r, p, s, newline, count, try_backref); *s = save; if (match != NULL) return((char *) match); else { start = s; len = end - start; } } return(NULL); }}#include <ctype.h>int delta0[256];unsigned char cmap[256]; /* (un)folded characters */unsigned char pattern[5000];int patlen;char *bmg_search(buffer, buflen) unsigned char *buffer; int buflen;{ register unsigned char *k, *strend, *s, *buflim; register int t; int j; if (patlen > buflen) return NULL; buflim = buffer + buflen; if (buflen > patlen * 4) strend = buflim - patlen * 4; else strend = buffer; s = buffer; k = buffer + patlen - 1; for (;;) { /* The dreaded inner loop, revisited. */ while (k < strend && (t = delta0[*k])) { k += t; k += delta0[*k]; k += delta0[*k]; } while (k < buflim && delta0[*k]) ++k; if (k == buflim) break; j = patlen - 1; s = k; while (cmap[*--s] == pattern[--j]) ; /* delta-less shortcut for literati, but short shrift for genetic engineers. */ if (j >= 0) k++; else /* submatch */ return ((char *)k); } return(NULL);}bmg_setup(pat, folded) /* compute "boyer-moore" delta table */ char *pat; int folded;{ /* ... HAKMEM lives ... */ int j; patlen = strlen(pat); if (folded) /* fold case while saving pattern */ for (j = 0; j < patlen; j++) pattern[j] = (isupper((int) pat[j]) ? (char) tolower((int) pat[j]) : pat[j]); else memcpy(pattern, pat, patlen); for (j = 0; j < 256; j++) { delta0[j] = patlen; cmap[j] = (char) j; /* could be done at compile time */ } for (j = 0; j < patlen - 1; j++) delta0[pattern[j]] = patlen - j - 1; delta0[pattern[patlen - 1]] = 0; if (folded) { for (j = 0; j < patlen - 1; j++) if (islower((int) pattern[j])) delta0[toupper((int) pattern[j])] = patlen - j - 1; if (islower((int) pattern[patlen - 1])) delta0[toupper((int) pattern[patlen - 1])] = 0; for (j = 'A'; j <= 'Z'; j++) cmap[j] = (char) tolower((int) j); }}#ifndef USG/* (groan) compatibility */char *strchr(s, c) char *s;{ return index(s, c);}char *strrchr(s, c) char *s;{ return rindex(s, c);}char *memcpy(d, s, n) char *d, *s;{ return bcopy(s, d, n);}#else#ifdef index /* we DON'T want the index macro to be expanded here */#undef index#endifchar *index(s, c) char *s;{ return strchr(s, c);}char *bcopy(s, d, n) char *s, *d;{ return memcpy(d, s, n);}char *bzero(s, n) char *s;{ return memset(s, 0, n);}bcmp(s, t, n) char *s, *t;{ return memcmp(s, t, n);}#endif :MPW:MPW Tools:Tools with Source:e?grep ƒ:grep.man
grep , egrep - print lines matching a regular expressionSYNOPSIS grep [ -CVbchilnsvwx ] [ -num ] [ -AB num ] [ [ -e ] expr | -f file ] [ files ... ]DESCRIPTION Grep searches the files listed in the arguments (or standard input if no files are given) for all lines that contain a match for the given expr. If any lines match, they are printed. Also, if any matches were found, grep will exit with a status of 0, but if no matches were found it will exit with a status of 1. This is useful for building shell scripts that use grep as a condition for, for example, the if state- ment. When invoked as egrep the syntax of the expr is slightly different; See below.REGULAR EXPRESSIONS (grep) (egrep) (explanation) c c a single (non-meta) character matches itself. ? ? matches any single character except newline. Was ‘.’. ≈ ≈ matches any 0 or more characters; equivalent to ‘?*’. ∂¿ ¿ postfix operator; preceeding item is optional. Was ‘?’. * * postfix operator; preceeding item 0 or more times. ∂+ + postfix operator; preceeding item 1 or more times. ∂| | infix operator; matches either argument. • • matches the empty string at the beginning of a line. Was ‘^’. ∞ ∞ matches the empty string at the end of a line. Was ‘$’. ∂< ∂< matches the empty string at the beginning of a word. Was ‘\<’. ∂> ∂> matches the empty string at the end of a word. Was ‘\>’. [chars] [chars] match any character in the given class; if the first character after [ is ¬, match any character not in the given class; a range of char- acters may be specified by first-last; for example, \W (below) is equivalent to the class [^A-Za-z0-9]. (¬ used to be ^). ∂( ∂) ( ) parentheses are used to override operator precedence. ®digit ®digit ®n matches a repeat of the text matched earlier in the regexp by the subexpression inside the nth opening parenthesis. Was ‘\’. ∂ ∂ any special character may be pre- ceded by a delta to match it literally. Was ‘\’. E¿grep's syntax compared to MPW's search utility: The | and ¿ operators have been added (¿ used to be ?). The «…» operation is not supported. The ® operator can be used in the search string (unlike search which only uses it in replace mode. It is used only to specify a previous expression, not to tag it. All expressions are tagged in order of appearance of (. The special use of ∂ (∂t, ∂n and ∂f) is not supported. (the following are for compatibility with GNU Emacs) \b \b matches the empty string at the edge of a word. \B \B matches the empty string if not at the edge of a word. \w \w matches word-constituent characters (letters & digits). \W \W matches characters that are not word-constituent. Operator precedence is (highest to lowest) ¿, *, and +, con- catenation, and finally |. All other constructs are syntac- tically identical to normal characters. For the truly interested, the file dfa.c describes (and implements) the exact grammar understood by the parser.OPTIONS -A num print <num> lines of context after every matching line -B num print num lines of context before every matching line -C print 2 lines of context on each side of every match -num print num lines of context on each side of every match -V print the version number on the diagnostic output -b print every match preceded by its byte offset -c print a total count of matching lines only -e expr search for expr; useful if expr begins with - -f file search for the expression contained in file -h don't display filenames on matches -i ignore case difference when comparing strings -l list files containing matches only -n print each match preceded by its line number -s run silently producing no output except error messages -v print only lines that contain no matches for the <expr> -w print only lines where the match is a complete word -x print only lines where the match is a whole lineSEE ALSO emacs(1), ed(1), sh(1), GNU Emacs ManualINCOMPATIBILITIES The following incompatibilities with UNIX grep exist: The context-dependent meaning of * is not quite the same (grep only). -b prints a byte offset instead of a block offset. The {m,n} construct of System V grep is not imple- mented.BUGS GNU e?grep has been thoroughly debugged and tested by several people over a period of several months; we think it's a reliable beast or we wouldn't distribute it. If by some fluke of the universe you discover a bug, send a detailed description (including options, regular expres- sions, and a copy of an input file that can reproduce it) to me, mike@wheaties.ai.mit.edu. There is also a newsgroup, gnu.utils.bug, for reporting FSF utility programs' bugs and fixes; but before reporting some- thing as a bug, please try to be sure that it really is a bug, not a misunderstanding or a deliberate feature. Also, include the version number of the utility program you are running in every bug report that you send in. Please do not send anything but bug reports to this newsgroup. Under MPW, if you want both egrep and grep, you have to maintain a copy under each name (no links on this file system).AVAILABILITY GNU grep is free; anyone may redistribute copies of grep to anyone under the terms stated in the GNU General Public License, a copy of which may be found in each copy of GNU Emacs. See also the comment at the beginning of the source code file grep.c. Copies of GNU grep may sometimes be received packaged with distributions of Unix systems, but it is never included in the scope of any license covering those systems. Such inclusion violates the terms on which distribution is per- mitted. In fact, the primary purpose of the General Public License is to prohibit anyone from attaching any other res- trictions to redistribution of any of the Free Software Foundation programs.AUTHORS Mike Haertel wrote the deterministic regexp code and the bulk of the program. James A. Woods is responsible for the hybridized search strategy of using Boyer-Moore-Gosper fixed-string search as a filter before calling the general regexp matcher. Arthur David Olson contributed code that finds fixed strings for the aforementioned BMG search for a large class of regexps. Richard Stallman wrote the backtracking regexp matcher that is used for \fIdigit backreferences, as well as the getopt that is provided for 4.2BSD sites. The backtracking matcher was originally written for GNU Emacs. D. A. Gwyn wrote the C alloca emulation that is provided so System V machines can run this program. (Alloca is used only by RMS' backtracking matcher, and then only rarely, so there is no loss if your machine doesn't have a "real" alloca.) Scott Anderson and Henry Spencer designed the regression tests used in the "regress" script. Paul Placeway wrote the original version of this manual page. Scott Lindsey mangled the code slightly to be MPW compatible.- :MPW:MPW Tools:Tools with Source:e?grep ƒ:Makefile
## Makefile for GNU e?grep## Add -DUSG for System V.# Add -sym full for SADE debuggingCFLAGS =DEBUG =# You may add getopt.o if your C library lacks getopt(); note that# 4.3BSD getopt() is said to be somewhat broken.# Add alloca.o if your machine does not support alloca().OBJS = grep.o dfa.o regex.o alloca.o getopt.oall ƒ regressregress ƒ grep cd tests; regress.sh ; cd ::egrep ƒ grepgrep ƒ {OBJS} Link -w -c 'MPS ' -t MPST {OBJS} ∂ {DEBUG} ∂ -sn STDIO=Main ∂ -sn INTENV=Main ∂ -sn %A5Init=Main ∂ "{Libraries}"Stubs.o ∂ "{CLibraries}"CRuntime.o ∂ "{CLibraries}"StdCLib.o ∂ "{CLibraries}"CInterface.o ∂ "{Libraries}"Interface.o ∂ "{Libraries}"ToolLibs.o ∂ -o egrep cp -y egrep {tools}grep mv -y egrep {tools}egrepclean ƒ unset exit # sigh. file name expansion causes errors if there's no match. rm -i grep egrep :tests:tmp.script khadafy.out rm -i ≈.o rm -i ≈.SYM rm -i ≈.makeout set exit 1.o ƒ .c c {default}.c {CFLAGS} -d USG -o {default}.odfa.o grep.o ƒ dfa.hgrep.o regex.o ƒ regex.h :MPW:MPW Tools:Tools with Source:e?grep ƒ:README
This README documents GNU e?grep version 1.2.Changes needed to the makefile under various perversions of Unix aredescribed therein.If the type "char" is unsigned on your machine, you will have to fixthe definition of the macro SIGN_EXTEND_CHAR() in regex.c. A reasonabledefinition might be: #define SIGN_EXTEND_CHAR(c) ((c)>(char)127?(c)-256:(c))GNU e?grep is provided "as is" with no warranty. The exact termsunder which you may use and (re)distribute this program are detailedin a comment at the top of grep.c.GNU e?grep is based on a fast lazy-state deterministic matcher (abouttwice as fast as stock Unix egrep) hybridized with a Boyer-Moore-Gospersearch for a fixed string that eliminates impossible text from beingconsidered by the full regexp matcher without necessarily having tolook at every character. The result is typically many times fasterthan Unix grep or egrep. (Regular expressions containing backreferencingmay run more slowly, however.)GNU e?grep attempts, as closely as possible, to understand compatiblythe regexp syntaxes of the Unix programs it replaces. The following tabledetails the various special characters understood in both the grep andegrep incarnations:(grep) (egrep) (explanation) . . matches any single character except newline \? ? postfix operator; preceeding item is optional * * postfix operator; preceeding item 0 or more times \+ + postfix operator; preceeding item 1 or more times \| | infix operator; matches either argument ^ ^ matches the empty string at the beginning of a line$ matches the empty string at the end of a line \< \< matches the empty string at the beginning of a word \> \> matches the empty string at the end of a word [chars] [chars] match any character in the given class; if the first character after [ is ^, match any character not in the given class; a range of characters may be specified by <first>-<last>; for example, \W (below) is equivalent to the class [^A-Za-z0-9] \( \) ( ) parentheses are used to override operator precedence \<1-9> \<1-9> \<n> matches a repeat of the text matched earlier in the regexp by the subexpression inside the nth opening parenthesis \ \ any special character may be preceded by a backslash to match it literally(the following are for compatibility with GNU Emacs) \b \b matches the empty string at the edge of a word \B \B matches the empty string if not at the edge of a word \w \w matches word-constituent characters (letters & digits) \W \W matches characters that are not word-constituentOperator precedence is (highest to lowest) ?, *, and +, concatenation,and finally |. All other constructs are syntactically identical tonormal characters. For the truly interested, a comment in dfa.c describesthe exact grammar understood by the parser.GNU e?grep understands the following command line options: -A <num> print <num> lines of context after every matching line -B <num> print <num> lines of context before every matching line -C print 2 lines of context on each side of every match -<num> print <num> lines of context on each side -V print the version number on stderr -b print every match preceded by its byte offset -c print a total count of matching lines only -e <expr> search for <expr>; useful if <expr> begins with - -f <file> take <expr> from the given <file> -h don't display filenames on matches -i ignore case difference when comparing strings -l list files containing matches only -n print each match preceded by its line number -s run silently producing no output except error messages -v print only lines that contain no matches for the <expr> -w print only lines where the match is a complete word -x print only lines where the match is a whole lineThe options understood by GNU e?grep are meant to be (nearly) compatiblewith both the BSD and System V versions of grep and egrep.The following incompatibilities with other versions of grep exist: the context-dependent meaning of * is not quite the same (grep only) -b prints a byte offset instead of a block offset the \{m,n\} construct of System V grep is not implementedGNU e?grep has been thoroughly debugged and tested by several peopleover a period of several months; we think it's a reliable beast or wewouldn't distribute it. If by some fluke of the universe you discovera bug, send a detailed description (including options, regularexpressions, and a copy of an input file that can reproduce it) to me,mike@wheaties.ai.mit.edu.GNU e?grep is brought to you by the efforts of several people: Mike Haertel wrote the deterministic regexp code and the bulk of the program. James A. Woods is responsible for the hybridized search strategy of using Boyer-Moore-Gosper fixed-string search as a filter before calling the general regexp matcher. Arthur David Olson contributed code that finds fixed strings for the aforementioned BMG search for a large class of regexps. Richard Stallman wrote the backtracking regexp matcher that is used for \<digit> backreferences, as well as the getopt that is provided for 4.2BSD sites. The backtracking matcher was originally written for GNU Emacs. D. A. Gwyn wrote the C alloca emulation that is provided so System V machines can run this program. (Alloca is used only by RMS' backtracking matcher, and then only rarely, so there is no loss if your machine doesn't have a "real" alloca.) Scott Anderson and Henry Spencer designed the regression tests used in the "regress" script. Paul Placeway wrote the manual page, based on this README.If you are interested in improving this program, you may wish to tryany of the following:1. Make backreferencing \<digit> faster. Right now, backreferencing is handled by calling the Emacs backtracking matcher to verify the partial match. This is slow; if the DFA routines could handle backreferencing themselves a speedup on the order of three to four times might occur in those cases where the backtracking matcher is called to verify nearly every line. Also, some portability problems due to the inclusion of the emacs matcher would be solved because it could then be eliminated. Note that expressions with backreferencing are not true regular expressions, and thus are not equivalent to any DFA. So this is hard.2. There is a bug in the backtracking matcher, regex.c, such that the | operator is not properly commutative. Let x and y be arbitrary regular expressions, and suppose both x and y have matches at some point in the target text. Then the regexp x|y should select the longest of the two matches. With the backtracking matcher, if the first match succeeds it does not even try the second, even though the second may be a longer match. This is obviously of no concern for grep, which does not care exactly where or how long a match is, so long as it knows it is there. On the other hand, the backtracking matcher is used in GNU AWK, wherein its behavior can only be considered a bug.3. Handle POSIX style regexps. I'm not sure if this could be called an improvement; some of the things on regexps in the POSIX draft I have seen are pretty sickening. But it would be useful in the interests of conforming to the standard. :MPW:MPW Tools:Tools with Source:e?grep ƒ:regex.c
/* Extended regular expression matching and search. Copyright (C) 1985 Free Software Foundation, Inc. NO WARRANTY BECAUSE THIS PROGRAM IS LICENSED FREE OF CHARGE, WE PROVIDE ABSOLUTELYNO WARRANTY, TO THE EXTENT PERMITTED BY APPLICABLE STATE LAW. EXCEPTWHEN OTHERWISE STATED IN WRITING, FREE SOFTWARE FOUNDATION, INC,RICHARD M. STALLMAN AND/OR OTHER PARTIES PROVIDE THIS PROGRAM "AS IS"WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING,BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY ANDFITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITYAND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVEDEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR ORCORRECTION. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW WILL RICHARD M.STALLMAN, THE FREE SOFTWARE FOUNDATION, INC., AND/OR ANY OTHER PARTYWHO MAY MODIFY AND REDISTRIBUTE THIS PROGRAM AS PERMITTED BELOW, BELIABLE TO YOU FOR DAMAGES, INCLUDING ANY LOST PROFITS, LOST MONIES, OROTHER SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THEUSE OR INABILITY TO USE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA ORDATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY THIRD PARTIES ORA FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS) THISPROGRAM, EVEN IF YOU HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCHDAMAGES, OR FOR ANY CLAIM BY ANY OTHER PARTY. GENERAL PUBLIC LICENSE TO COPY 1. You may copy and distribute verbatim copies of this source fileas you receive it, in any medium, provided that you conspicuously andappropriately publish on each copy a valid copyright notice "Copyright(C) 1985 Free Software Foundation, Inc."; and include following thecopyright notice a verbatim copy of the above disclaimer of warrantyand of this License. You may charge a distribution fee for thephysical act of transferring a copy. 2. You may modify your copy or copies of this source file orany portion of it, and copy and distribute such modifications underthe terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in win part contains or is a derivative of this program or any part thereof, to be licensed at no charge to all third parties on terms identical to those contained in this License Agreement (except that you may choose to grant more extensive warranty protection to some or all third parties, at your option). c) You may charge a distribution fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee.Mere aggregation of another unrelated program with this program (or itsderivative) on a volume of a storage or distribution medium does not bringthe other program under the scope of these terms. 3. You may copy and distribute this program (or a portion or derivativeof it, under Paragraph 2) in object code or executable form under the termsof Paragraphs 1 and 2 above provided that you also do one of the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal shipping charge) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.)For an executable file, complete source code means all the source code forall modules it contains; but, as a special exception, it need not includesource code for modules which are standard libraries that accompany theoperating system on which the executable file runs. 4. You may not copy, sublicense, distribute or transfer this programexcept as expressly provided under this License Agreement. Any attemptotherwise to copy, sublicense, distribute or transfer this program is void andyour rights to use the program under this License agreement shall beautomatically terminated. However, parties who have received computersoftware programs from you with this License Agreement will not havetheir licenses terminated so long as such parties remain in full compliance. 5. If you wish to incorporate parts of this program into other freeprograms whose distribution conditions are different, write to the FreeSoftware Foundation at 675 Mass Ave, Cambridge, MA 02139. We have not yetworked out a simple rule that can be stated here, but we will often permitthis. We will be guided by the two goals of preserving the free status ofall derivatives of our free software and of promoting the sharing and reuse ofsoftware.In other words, you are welcome to use, share and improve this program.You are forbidden to forbid anyone else to use, share and improvewhat you give them. Help stamp out software-hoarding! *//* Prominent notice: This file modified 2/89 for MPW compatibility by Scott Lindsey, <scott@claris.com> *//* To test, compile with -Dtest. This Dtestable feature turns this into a self-contained program which reads a pattern, describes how it compiles, then reads a string and searches for it. */#ifdef emacs/* The `emacs' switch turns on certain special matching commands that make sense only in emacs. */#include "config.h"#include "lisp.h"#include "buffer.h"#include "syntax.h"#else /* not emacs */#ifdef USG#define bcopy(s,d,n) memcpy((d),(s),(n))#define bcmp(s1,s2,n) memcmp((s1),(s2),(n))#define bzero(s,n) memset((s),0,(n))#endif/* Make alloca work the best possible way. */#ifdef __GNUC__#define alloca __builtin_alloca#else#ifdef sparc#include <alloca.h>#endif#endif/* * Define the syntax stuff, so we can do the \<...\> things. */#ifndef Sword /* must be non-zero in some of the tests below... */#define Sword 1#endif#define SYNTAX(c) re_syntax_table[c]#ifdef SYNTAX_TABLEchar *re_syntax_table;#elsestatic char re_syntax_table[256];static voidinit_syntax_once (){ register int c; static int done = 0; if (done) return; bzero (re_syntax_table, sizeof re_syntax_table); for (c = 'a'; c <= 'z'; c++) re_syntax_table[c] = Sword; for (c = 'A'; c <= 'Z'; c++) re_syntax_table[c] = Sword; for (c = '0'; c <= '9'; c++) re_syntax_table[c] = Sword; done = 1;}#endif /* SYNTAX_TABLE */#endif /* not emacs */#include "regex.h"/* Number of failure points to allocate space for initially, when matching. If this number is exceeded, more space is allocated, so it is not a hard limit. */#ifndef NFAILURES#define NFAILURES 80#endif /* NFAILURES *//* width of a byte in bits */#define BYTEWIDTH 8#ifndef SIGN_EXTEND_CHAR#define SIGN_EXTEND_CHAR(x) (x)#endif static int obscure_syntax = 0;/* Specify the precise syntax of regexp for compilation. This provides for compatibility for various utilities which historically have different, incompatible syntaxes. The argument SYNTAX is a bit-mask containing the two bits RE_NO_BK_PARENS and RE_NO_BK_VBAR. */intre_set_syntax (syntax){ int ret; ret = obscure_syntax; obscure_syntax = syntax; return ret;} /* re_compile_pattern takes a regular-expression string and converts it into a buffer full of byte commands for matching. PATTERN is the address of the pattern string SIZE is the length of it. BUFP is a struct re_pattern_buffer * which points to the info on where to store the byte commands. This structure contains a char * which points to the actual space, which should have been obtained with malloc. re_compile_pattern may use realloc to grow the buffer space. The number of bytes of commands can be found out by looking in the struct re_pattern_buffer that bufp pointed to, after re_compile_pattern returns.*/#define PATPUSH(ch) (*b++ = (char) (ch))#define PATFETCH(c) \ {if (p == pend) goto end_of_pattern; \ c = * (unsigned char *) p++; \ if (translate) c = translate[c]; }#define PATFETCH_RAW(c) \ {if (p == pend) goto end_of_pattern; \ c = * (unsigned char *) p++; }#define PATUNFETCH p--#define EXTEND_BUFFER \ { char *old_buffer = bufp->buffer; \ if (bufp->allocated == (1<<16)) goto too_big; \ bufp->allocated *= 2; \ if (bufp->allocated > (1<<16)) bufp->allocated = (1<<16); \ if (!(bufp->buffer = (char *) realloc (bufp->buffer, bufp->allocated))) \ goto memory_exhausted; \ c = bufp->buffer - old_buffer; \ b += c; \ if (fixup_jump) \ fixup_jump += c; \ if (laststart) \ laststart += c; \ begalt += c; \ if (pending_exact) \ pending_exact += c; \ }static int store_jump (), insert_jump ();char *re_compile_pattern (pattern, size, bufp) char *pattern; int size; struct re_pattern_buffer *bufp;{ register char *b = bufp->buffer; register char *p = pattern; char *pend = pattern + size; register unsigned c, c1; char *p1; unsigned char *translate = (unsigned char *) bufp->translate; /* address of the count-byte of the most recently inserted "exactn" command. This makes it possible to tell whether a new exact-match character can be added to that command or requires a new "exactn" command. */ char *pending_exact = 0; /* address of the place where a forward-jump should go to the end of the containing expression. Each alternative of an "or", except the last, ends with a forward-jump of this sort. */ char *fixup_jump = 0; /* address of start of the most recently finished expression. This tells postfix * where to find the start of its operand. */ char *laststart = 0; /* In processing a repeat, 1 means zero matches is allowed */ char zero_times_ok; /* In processing a repeat, 1 means many matches is allowed */ char many_times_ok; /* address of beginning of regexp, or inside of last \( */ char *begalt = b; /* Stack of information saved by \( and restored by \). Four stack elements are pushed by each \(: First, the value of b. Second, the value of fixup_jump. Third, the value of regnum. Fourth, the value of begalt. */ int stackb[40]; int *stackp = stackb; int *stacke = stackb + 40; int *stackt; /* Counts \('s as they are encountered. Remembered for the matching \), where it becomes the "register number" to put in the stop_memory command */ int regnum = 1; bufp->fastmap_accurate = 0;#ifndef emacs#ifndef SYNTAX_TABLE /* * Initialize the syntax table. */ init_syntax_once();#endif#endif if (bufp->allocated == 0) { bufp->allocated = 28; if (bufp->buffer) /* EXTEND_BUFFER loses when bufp->allocated is 0 */ bufp->buffer = (char *) realloc (bufp->buffer, 28); else /* Caller did not allocate a buffer. Do it for him */ bufp->buffer = (char *) malloc (28); if (!bufp->buffer) goto memory_exhausted; begalt = b = bufp->buffer; } while (p != pend) { if (b - bufp->buffer > bufp->allocated - 10) /* Note that EXTEND_BUFFER clobbers c */ EXTEND_BUFFER; PATFETCH (c); switch (c) { case 0xB0: if (obscure_syntax & RE_TIGHT_VBAR) { if (! (obscure_syntax & RE_CONTEXT_INDEP_OPS) && p != pend) goto normal_char; /* Make operand of last vbar end before this `$'. */ if (fixup_jump) store_jump (fixup_jump, jump, b); fixup_jump = 0; PATPUSH (endline); break; } /* $ means succeed if at end of line, but only in special contexts. If randomly in the middle of a pattern, it is a normal character. */ if (p == pend || *p == '\n' || (obscure_syntax & RE_CONTEXT_INDEP_OPS) || (obscure_syntax & RE_NO_BK_PARENS ? *p == ')' : *p == 0xB6 && p[1] == ')') || (obscure_syntax & RE_NO_BK_VBAR ? *p == '|' : *p == 0xB6 && p[1] == '|')) { PATPUSH (endline); break; } goto normal_char; case 0xA5: /* ^ means succeed if at beg of line, but only if no preceding pattern. */ if (laststart && p[-2] != '\n' && ! (obscure_syntax & RE_CONTEXT_INDEP_OPS)) goto normal_char; if (obscure_syntax & RE_TIGHT_VBAR) { if (p != pattern + 1 && ! (obscure_syntax & RE_CONTEXT_INDEP_OPS)) goto normal_char; PATPUSH (begline); begalt = b; } else PATPUSH (begline); break; case '+': case 0xC0: if (obscure_syntax & RE_BK_PLUS_QM) goto normal_char; handle_plus: case '*': /* If there is no previous pattern, char not special. */ if (!laststart && ! (obscure_syntax & RE_CONTEXT_INDEP_OPS)) goto normal_char; /* If there is a sequence of repetition chars, collapse it down to equivalent to just one. */ zero_times_ok = 0; many_times_ok = 0; while (1) { zero_times_ok |= c != '+'; many_times_ok |= c != 0xC0; if (p == pend) break; PATFETCH (c); if (c == '*') ; else if (!(obscure_syntax & RE_BK_PLUS_QM) && (c == '+' || c == 0xC0)) ; else if ((obscure_syntax & RE_BK_PLUS_QM) && c == 0xB6) { int c1; PATFETCH (c1); if (!(c1 == '+' || c1 == 0xC0)) { PATUNFETCH; PATUNFETCH; break; } c = c1; } else { PATUNFETCH; break; } } /* Star, etc. applied to an empty pattern is equivalent to an empty pattern. */ if (!laststart) break; /* Now we know whether 0 matches is allowed, and whether 2 or more matches is allowed. */ if (many_times_ok) { /* If more than one repetition is allowed, put in a backward jump at the end. */ store_jump (b, maybe_finalize_jump, laststart - 3); b += 3; } insert_jump (on_failure_jump, laststart, b + 3, b); pending_exact = 0; b += 3; if (!zero_times_ok) { /* At least one repetition required: insert before the loop a skip over the initial on-failure-jump instruction */ insert_jump (dummy_failure_jump, laststart, laststart + 6, b); b += 3; } break; case 0xC5: *b = '?'; laststart = b; PATPUSH (anychar); c = '*'; goto handle_plus; case '?': laststart = b; PATPUSH (anychar); break; case '[': while (b - bufp->buffer > bufp->allocated - 3 - (1 << BYTEWIDTH) / BYTEWIDTH) /* Note that EXTEND_BUFFER clobbers c */ EXTEND_BUFFER; laststart = b; if (*p == 0xC2) PATPUSH (charset_not), p++; else PATPUSH (charset); p1 = p; PATPUSH ((1 << BYTEWIDTH) / BYTEWIDTH); /* Clear the whole map */ bzero (b, (1 << BYTEWIDTH) / BYTEWIDTH); /* Read in characters and ranges, setting map bits */ while (1) { PATFETCH (c); if (c == ']' && p != p1 + 1) break; if (*p == '-' && p[1] != ']') { PATFETCH (c1); PATFETCH (c1); while (c <= c1) b[c / BYTEWIDTH] |= 1 << (c % BYTEWIDTH), c++; } else { b[c / BYTEWIDTH] |= 1 << (c % BYTEWIDTH); } } /* Discard any bitmap bytes that are all 0 at the end of the map. Decrement the map-length byte too. */ while ((int) b[-1] > 0 && b[b[-1] - 1] == 0) b[-1]--; b += b[-1]; break; case '(': if (! (obscure_syntax & RE_NO_BK_PARENS)) goto normal_char; else goto handle_open; case
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:e?grep ƒ:regex.c
+++++ Continued from previous card +++++
')': if (! (obscure_syntax & RE_NO_BK_PARENS)) goto normal_char; else goto handle_close; case '\n': if (! (obscure_syntax & RE_NEWLINE_OR)) goto normal_char; else goto handle_bar; case '|': if (! (obscure_syntax & RE_NO_BK_VBAR)) goto normal_char; else goto handle_bar; case 0xA8: if (p == pend) goto invalid_pattern; PATFETCH_RAW (c); if (c < '1' || c > '9') goto bad_group_num; c1 = c - '0'; if (c1 >= regnum) goto normal_char; for (stackt = stackp - 2; stackt > stackb; stackt -= 4) if (*stackt == c1) goto normal_char; laststart = b; PATPUSH (duplicate); PATPUSH (c1); break; case 0xB6: if (p == pend) goto invalid_pattern; PATFETCH_RAW (c); switch (c) { case '(': if (obscure_syntax & RE_NO_BK_PARENS) goto normal_backsl; handle_open: if (stackp == stacke) goto nesting_too_deep; if (regnum < RE_NREGS) { PATPUSH (start_memory); PATPUSH (regnum); } *stackp++ = b - bufp->buffer; *stackp++ = fixup_jump ? fixup_jump - bufp->buffer + 1 : 0; *stackp++ = regnum++; *stackp++ = begalt - bufp->buffer; fixup_jump = 0; laststart = 0; begalt = b; break; case ')': if (obscure_syntax & RE_NO_BK_PARENS) goto normal_backsl; handle_close: if (stackp == stackb) goto unmatched_close; begalt = *--stackp + bufp->buffer; if (fixup_jump) store_jump (fixup_jump, jump, b); if (stackp[-1] < RE_NREGS) { PATPUSH (stop_memory); PATPUSH (stackp[-1]); } stackp -= 2; fixup_jump = 0; if (*stackp) fixup_jump = *stackp + bufp->buffer - 1; laststart = *--stackp + bufp->buffer; break; case '|': if (obscure_syntax & RE_NO_BK_VBAR) goto normal_backsl; handle_bar: insert_jump (on_failure_jump, begalt, b + 6, b); pending_exact = 0; b += 3; if (fixup_jump) store_jump (fixup_jump, jump, b); fixup_jump = b; b += 3; laststart = 0; begalt = b; break;#ifdef emacs case '=': PATPUSH (at_dot); break; case 's': laststart = b; PATPUSH (syntaxspec); PATFETCH (c); PATPUSH (syntax_spec_code[c]); break; case 'S': laststart = b; PATPUSH (notsyntaxspec); PATFETCH (c); PATPUSH (syntax_spec_code[c]); break;#endif /* emacs */ case 'w': laststart = b; PATPUSH (wordchar); break; case 'W': laststart = b; PATPUSH (notwordchar); break; case '<': PATPUSH (wordbeg); break; case '>': PATPUSH (wordend); break; case 'b': PATPUSH (wordbound); break; case 'B': PATPUSH (notwordbound); break; case '`': PATPUSH (begbuf); break; case '\'': PATPUSH (endbuf); break; case '+': case 0xC0: if (obscure_syntax & RE_BK_PLUS_QM) goto handle_plus; default: normal_backsl: /* You might think it would be useful for \ to mean not to translate; but if we don't translate it it will never match anything. */ if (translate) c = translate[c]; goto normal_char; } break; default: normal_char: if (!pending_exact || pending_exact + *pending_exact + 1 != b || *pending_exact == 0177 || *p == '*' || *p == '^' || ((obscure_syntax & RE_BK_PLUS_QM) ? *p == 0xB6 && (p[1] == '+' || p[1] == 0xC0) : (*p == '+' || *p == 0xC0))) { laststart = b; PATPUSH (exactn); pending_exact = b; PATPUSH (0); } PATPUSH (c); (*pending_exact)++; } } if (fixup_jump) store_jump (fixup_jump, jump, b); if (stackp != stackb) goto unmatched_open; bufp->used = b - bufp->buffer; return 0; invalid_pattern: return "Invalid regular expression"; unmatched_open: return "Unmatched ∂("; unmatched_close: return "Unmatched ∂)"; end_of_pattern: return "Premature end of regular expression"; nesting_too_deep: return "Nesting too deep"; too_big: return "Regular expression too big"; bad_group_num: return "Incorrect use of ®"; memory_exhausted: return "Memory exhausted";}/* Store where `from' points a jump operation to jump to where `to' points. `opcode' is the opcode to store. */static intstore_jump (from, opcode, to) char *from, *to; char opcode;{ from[0] = opcode; from[1] = (to - (from + 3)) & 0377; from[2] = (to - (from + 3)) >> 8;}/* Open up space at char FROM, and insert there a jump to TO. CURRENT_END gives te end of the storage no in use, so we know how much data to copy up. OP is the opcode of the jump to insert. If you call this function, you must zero out pending_exact. */static intinsert_jump (op, from, to, current_end) char op; char *from, *to, *current_end;{ register char *pto = current_end + 3; register char *pfrom = current_end; while (pfrom != from) *--pto = *--pfrom; store_jump (from, op, to);} /* Given a pattern, compute a fastmap from it. The fastmap records which of the (1 << BYTEWIDTH) possible characters can start a string that matches the pattern. This fastmap is used by re_search to skip quickly over totally implausible text. The caller must supply the address of a (1 << BYTEWIDTH)-byte data area as bufp->fastmap. The other components of bufp describe the pattern to be used. */voidre_compile_fastmap (bufp) struct re_pattern_buffer *bufp;{ unsigned char *pattern = (unsigned char *) bufp->buffer; int size = bufp->used; register char *fastmap = bufp->fastmap; register unsigned char *p = pattern; register unsigned char *pend = pattern + size; register int j, k; unsigned char *translate = (unsigned char *) bufp->translate; unsigned char *stackb[NFAILURES]; unsigned char **stackp = stackb;#pragma unused(k) bzero (fastmap, (1 << BYTEWIDTH)); bufp->fastmap_accurate = 1; bufp->can_be_null = 0; while (p) { if (p == pend) { bufp->can_be_null = 1; break; }#ifdef SWITCH_ENUM_BUG switch ((int) ((enum regexpcode) *p++))#else switch ((enum regexpcode) *p++)#endif { case exactn: if (translate) fastmap[translate[p[1]]] = 1; else fastmap[p[1]] = 1; break; case begline: case before_dot: case at_dot: case after_dot: case begbuf: case endbuf: case wordbound: case notwordbound: case wordbeg: case wordend: continue; case endline: if (translate) fastmap[translate['\n']] = 1; else fastmap['\n'] = 1; if (bufp->can_be_null != 1) bufp->can_be_null = 2; break; case finalize_jump: case maybe_finalize_jump: case jump: case dummy_failure_jump: bufp->can_be_null = 1; j = *p++ & 0377; j += SIGN_EXTEND_CHAR (*(char *)p) << 8; p += j + 1; /* The 1 compensates for missing ++ above */ if (j > 0) continue; /* Jump backward reached implies we just went through the body of a loop and matched nothing. Opcode jumped to should be an on_failure_jump. Just treat it like an ordinary jump. For a * loop, it has pushed its failure point already; if so, discard that as redundant. */ if ((enum regexpcode) *p != on_failure_jump) continue; p++; j = *p++ & 0377; j += SIGN_EXTEND_CHAR (*(char *)p) << 8; p += j + 1; /* The 1 compensates for missing ++ above */ if (stackp != stackb && *stackp == p) stackp--; continue; case on_failure_jump: j = *p++ & 0377; j += SIGN_EXTEND_CHAR (*(char *)p) << 8; p++; *++stackp = p + j; continue; case start_memory: case stop_memory: p++; continue; case duplicate: bufp->can_be_null = 1; fastmap['\n'] = 1; case anychar: for (j = 0; j < (1 << BYTEWIDTH); j++) if (j != '\n') fastmap[j] = 1; if (bufp->can_be_null) return; /* Don't return; check the alternative paths so we can set can_be_null if appropriate. */ break; case wordchar: for (j = 0; j < (1 << BYTEWIDTH); j++) if (SYNTAX (j) == Sword) fastmap[j] = 1; break; case notwordchar: for (j = 0; j < (1 << BYTEWIDTH); j++) if (SYNTAX (j) != Sword) fastmap[j] = 1; break;#ifdef emacs case syntaxspec: k = *p++; for (j = 0; j < (1 << BYTEWIDTH); j++) if (SYNTAX (j) == (enum syntaxcode) k) fastmap[j] = 1; break; case notsyntaxspec: k = *p++; for (j = 0; j < (1 << BYTEWIDTH); j++) if (SYNTAX (j) != (enum syntaxcode) k) fastmap[j] = 1; break;#endif /* emacs */ case charset: for (j = *p++ * BYTEWIDTH - 1; j >= 0; j--) if (p[j / BYTEWIDTH] & (1 << (j % BYTEWIDTH))) { if (translate) fastmap[translate[j]] = 1; else fastmap[j] = 1; } break; case charset_not: /* Chars beyond end of map must be allowed */ for (j = *p * BYTEWIDTH; j < (1 << BYTEWIDTH); j++) if (translate) fastmap[translate[j]] = 1; else fastmap[j] = 1; for (j = *p++ * BYTEWIDTH - 1; j >= 0; j--) if (!(p[j / BYTEWIDTH] & (1 << (j % BYTEWIDTH)))) { if (translate) fastmap[translate[j]] = 1; else fastmap[j] = 1; } break; } /* Get here means we have successfully found the possible starting characters of one path of the pattern. We need not follow this path any farther. Instead, look at the next alternative remembered in the stack. */ if (stackp != stackb) p = *stackp--; else break; }} /* Like re_search_2, below, but only one string is specified. */intre_search (pbufp, string, size, startpos, range, regs) struct re_pattern_buffer *pbufp; char *string; int size, startpos, range; struct re_registers *regs;{ return re_search_2 (pbufp, 0, 0, string, size, startpos, range, regs, size);}/* Like re_match_2 but tries first a match starting at index STARTPOS, then at STARTPOS + 1, and so on. RANGE is the number of places to try before giving up. If RANGE is negative, the starting positions tried are STARTPOS, STARTPOS - 1, etc. It is up to the caller to make sure that range is not so large as to take the starting position outside of the input strings.The value returned is the position at which the match was found, or -1 if no match was found, or -2 if error (such as failure stack overflow). */intre_search_2 (pbufp, string1, size1, string2, size2, startpos, range, regs, mstop) struct re_pattern_buffer *pbufp; char *string1, *string2; int size1, size2; int startpos; register int range; struct re_registers *regs; int mstop;{ register char *fastmap = pbufp->fastmap; register unsigned char *translate = (unsigned char *) pbufp->translate; int total = size1 + size2; int val; /* Update the fastmap now if not correct already */ if (fastmap && !pbufp->fastmap_accurate) re_compile_fastmap (pbufp); /* Don't waste time in a long search for a pattern that says it is anchored. */ if (pbufp->used > 0 && (enum regexpcode) pbufp->buffer[0] == begbuf && range > 0) { if (startpos > 0) return -1; else range = 1; } while (1) { /* If a fastmap is supplied, skip quickly over characters that cannot possibly be the start of a match. Note, however, that if the pattern can possibly match the null string, we must test it at each starting point so that we take the first null string we get. */ if (fastmap && startpos < total && pbufp->can_be_null != 1) { if (range > 0) { register int lim = 0; register unsigned char *p; int irange = range; if (startpos < size1 && startpos + range >= size1) lim = range - (size1 - startpos); p = ((unsigned char *) &(startpos >= size1 ? string2 - size1 : string1)[startpos]); if (translate) { while (range > lim && !fastmap[translate[*p++]]) range--; } else { while (range > lim && !fastmap[*p++]) range--; } startpos += irange - range; } else { register unsigned char c; if (startpos >= size1) c = string2[startpos - size1]; else c = string1[startpos]; c &= 0xff; if (translate ? !fastmap[translate[c]] : !fastmap[c]) goto advance; } } if (range >= 0 && startpos == total && fastmap && pbufp->can_be_null == 0) return -1; val = re_match_2 (pbufp, string1, size1, string2, size2, startpos, regs, mstop); if (0 <= val) { if (val == -2) return -2; return startpos; }#ifdef C_ALLOCA alloca (0);#endif /* C_ALLOCA */ advance: if (!range) break; if (range > 0) range--, startpos++; else range++, startpos--; } return -1;} #ifndef emacs /* emacs never uses this */intre_match (pbufp, string, size, pos, regs) struct re_pattern_buffer *pbufp; char *string; int size, pos; struct re_registers *regs;{ return re_match_2 (pbufp, 0, 0, string, size, pos, regs, size);}#endif /* emacs *//* Maximum size of failure stack. Beyond this, overflow is an error. */int re_max_failures = 2000;static int bcmp_translate();/* Match the pattern described by PBUFP against data which is the virtual concatenation of STRING1 and STRING2. SIZE1 and SIZE2 are the sizes of the two data strings. Start the match at position POS. Do not consider matching past the position MSTOP. If pbufp->fastmap is nonzero, then it had better be up to date. The reason that the data to match are specified as two components which are to be regarded as concatenated is so this function can be used directly on the contents of an Emacs buffer. -1 is returned if there is no match. -2 is returned if there is an error (such as match stack overflow). Otherwise the value is the length of the substring which was matched. */intre_match_2 (pbufp, string1, size1, string2, size2, pos, regs, mstop) struct re_pattern_buffer *pbufp; unsigned char *string1, *string2; int size1, size2; int pos; struct re_registers *regs; int mstop;{ register unsigned char *p = (unsigned char *) pbufp->buffer; register unsigned char *pend = p + pbufp->used; /* End of first string */ unsigned char *end1; /* End of second string */ unsigned char *end2; /* Pointer just past last char to consider matching */ unsigned char *end_match_1atch_2; register unsigned char *d, *dend; register int mcnt; unsigned char *translate = (unsigned char *) pbufp->translate; /* Failure point stack. Each place that can handle a failure further down the line pushes a failure point on this stack. It consists of two char *'s. The first one pushed is where to resume scanning the pattern; the second pushed is where to resume scanning the strings. If the latter is zero, the failure point is a "dummy". If a failure happens and the innermost failure point is dormant, it discards that failure point and tries the next one. */ unsigned char *initial_stack[2 * NFAILURES]; unsigned char **stackb = initial_stack; unsigned char **stackp = stackb, **stacke = &stackb[2 * NFAILURES]; /* Information on the "contents" of registers. These are pointers into the input strings; they record just what was matched (on this attempt) by some part of the pattern. The start_memory command stores the start of a register's contents and the stop_memory command stores the end. At that point, regstart[regnum] points to the first character in the register, regend[regnum] points to the first character
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:e?grep ƒ:regex.c
+++++ Continued from previous card +++++
beyond the end of the register, regstart_seg1[regnum] is true iff regstart[regnum] points into string1, and regend_seg1[regnum] is true iff regend[regnum] points into string1. */ unsigned char *regstart[RE_NREGS]; unsigned char *regend[RE_NREGS]; unsigned char regstart_seg1[RE_NREGS], regend_seg1[RE_NREGS]; /* Set up pointers to ends of strings. Don't allow the second string to be empty unless both are empty. */ if (!size2) { string2 = string1; size2 = size1; string1 = 0; size1 = 0; } end1 = string1 + size1; end2 = string2 + size2; /* Compute where to stop matching, within the two strings */ if (mstop <= size1) { end_match_1 = string1 + mstop; end_match_2 = string2; } else { end_match_1 = end1; end_match_2 = string2 + mstop - size1; } /* Initialize \) text positions to -1 to mark ones that no \( or \) has been seen for. */ for (mcnt = 0; mcnt < sizeof (regend) / sizeof (*regend); mcnt++) regend[mcnt] = (unsigned char *) -1; /* `p' scans through the pattern as `d' scans through the data. `dend' is the end of the input string that `d' points within. `d' is advanced into the following input string whenever necessary, but this happens before fetching; therefore, at the beginning of the loop, `d' can be pointing at the end of a string, but it cannot equal string2. */ if (pos <= size1) d = string1 + pos, dend = end_match_1; else d = string2 + pos - size1, dend = end_match_2;/* Write PREFETCH; just before fetching a character with *d. */#define PREFETCH \ while (d == dend) \ { if (dend == end_match_2) goto fail; /* end of string2 => failure */ \ d = string2; /* end of string1 => advance to string2. */ \ dend = end_match_2; } /* This loop loops over pattern commands. It exits by returning from the function if match is complete, or it drops through if match fails at this starting point in the input data. */ while (1) { if (p == pend) /* End of pattern means we have succeeded! */ { /* If caller wants register contents data back, convert it to indices */ if (regs) { regs->start[0] = pos; if (dend == end_match_1) regs->end[0] = d - string1; else regs->end[0] = d - string2 + size1; for (mcnt = 1; mcnt < RE_NREGS; mcnt++) { if (regend[mcnt] == (unsigned char *) -1) { regs->start[mcnt] = -1; regs->end[mcnt] = -1; continue; } if (regstart_seg1[mcnt]) regs->start[mcnt] = regstart[mcnt] - string1; else regs->start[mcnt] = regstart[mcnt] - string2 + size1; if (regend_seg1[mcnt]) regs->end[mcnt] = regend[mcnt] - string1; else regs->end[mcnt] = regend[mcnt] - string2 + size1; } } if (dend == end_match_1) return (d - string1 - pos); else return d - string2 + size1 - pos; } /* Otherwise match next pattern command */#ifdef SWITCH_ENUM_BUG switch ((int) ((enum regexpcode) *p++))#else switch ((enum regexpcode) *p++)#endif { /* \( is represented by a start_memory, \) by a stop_memory. Both of those commands contain a "register number" argument. The text matched within the \( and \) is recorded under that number. Then, \<digit> turns into a `duplicate' command which is followed by the numeric value of <digit> as the register number. */ case start_memory: regstart[*p] = d; regstart_seg1[*p++] = (dend == end_match_1); break; case stop_memory: regend[*p] = d; regend_seg1[*p++] = (dend == end_match_1); break; case duplicate: { int regno = *p++; /* Get which register to match against */ register unsigned char *d2, *dend2; d2 = regstart[regno]; dend2 = ((regstart_seg1[regno] == regend_seg1[regno]) ? regend[regno] : end_match_1); while (1) { /* Advance to next segment in register contents, if necessary */ while (d2 == dend2) { if (dend2 == end_match_2) break; if (dend2 == regend[regno]) break; d2 = string2, dend2 = regend[regno]; /* end of string1 => advance to string2. */ } /* At end of register contents => success */ if (d2 == dend2) break; /* Advance to next segment in data being matched, if necessary */ PREFETCH; /* mcnt gets # consecutive chars to compare */ mcnt = dend - d; if (mcnt > dend2 - d2) mcnt = dend2 - d2; /* Compare that many; failure if mismatch, else skip them. */ if (translate ? bcmp_translate (d, d2, mcnt, translate) : bcmp (d, d2, mcnt)) goto fail; d += mcnt, d2 += mcnt; } } break; case anychar: /* fetch a data character */ PREFETCH; /* Match anything but a newline. */ if ((translate ? translate[*d++] : *d++) == '\n') goto fail; break; case charset: case charset_not: { /* Nonzero for charset_not */ int not = 0; register int c; if (*(p - 1) == (unsigned char) charset_not) not = 1; /* fetch a data character */ PREFETCH; if (translate) c = translate [*d]; else c = *d; if (c < *p * BYTEWIDTH && p[1 + c / BYTEWIDTH] & (1 << (c % BYTEWIDTH))) not = !not; p += 1 + *p; if (!not) goto fail; d++; break; } case begline: if (d == string1 || d[-1] == '\n') break; goto fail; case endline: if (d == end2 || (d == end1 ? (size2 == 0 || *string2 == '\n') : *d == '\n')) break; goto fail; /* "or" constructs ("|") are handled by starting each alternative with an on_failure_jump that points to the start of the next alternative. Each alternative except the last ends with a jump to the joining point. (Actually, each jump except for the last one really jumps to the following jump, because tensioning the jumps is a hassle.) */ /* The start of a stupid repeat has an on_failure_jump that points past the end of the repeat text. This makes a failure point so that, on failure to match a repetition, matching restarts past as many repetitions have been found with no way to fail and look for another one. */ /* A smart repeat is similar but loops back to the on_failure_jump so that each repetition makes another failure point. */ case on_failure_jump: if (stackp == stacke) { unsigned char **stackx; if (stacke - stackb > re_max_failures * 2) return -2; stackx = (unsigned char **) alloca (2 * (stacke - stackb) * sizeof (char *)); bcopy (stackb, stackx, (stacke - stackb) * sizeof (char *)); stackp = stackx + (stackp - stackb); stacke = stackx + 2 * (stacke - stackb); stackb = stackx; } mcnt = *p++ & 0377; mcnt += SIGN_EXTEND_CHAR (*(char *)p) << 8; p++; *stackp++ = mcnt + p; *stackp++ = d; break; /* The end of a smart repeat has an maybe_finalize_jump back. Change it either to a finalize_jump or an ordinary jump. */ case maybe_finalize_jump: mcnt = *p++ & 0377; mcnt += SIGN_EXTEND_CHAR (*(char *)p) << 8; p++; { register unsigned char *p2 = p; /* Compare what follows with the begining of the repeat. If we can establish that there is nothing that they would both match, we can change to finalize_jump */ while (p2 != pend && (*p2 == (unsigned char) stop_memory || *p2 == (unsigned char) start_memory)) p2++; if (p2 == pend) p[-3] = (unsigned char) finalize_jump; else if (*p2 == (unsigned char) exactn || *p2 == (unsigned char) endline) { register int c = *p2 == (unsigned char) endline ? '\n' : p2[2]; register unsigned char *p1 = p + mcnt; /* p1[0] ... p1[2] are an on_failure_jump. Examine what follows that */ if (p1[3] == (unsigned char) exactn && p1[5] != c) p[-3] = (unsigned char) finalize_jump; else if (p1[3] == (unsigned char) charset || p1[3] == (unsigned char) charset_not) { int not = p1[3] == (unsigned char) charset_not; if (c < p1[4] * BYTEWIDTH && p1[5 + c / BYTEWIDTH] & (1 << (c % BYTEWIDTH))) not = !not; /* not is 1 if c would match */ /* That means it is not safe to finalize */ if (!not) p[-3] = (unsigned char) finalize_jump; } } } p -= 2; if (p[-1] != (unsigned char) finalize_jump) { p[-1] = (unsigned char) jump; goto nofinalize; } /* The end of a stupid repeat has a finalize-jump back to the start, where another failure point will be made which will point after all the repetitions found so far. */ case finalize_jump: stackp -= 2; case jump: nofinalize: mcnt = *p++ & 0377; mcnt += SIGN_EXTEND_CHAR (*(char *)p) << 8; p += mcnt + 1; /* The 1 compensates for missing ++ above */ break; case dummy_failure_jump: if (stackp == stacke) { unsigned char **stackx = (unsigned char **) alloca (2 * (stacke - stackb) * sizeof (char *)); bcopy (stackb, stackx, (stacke - stackb) * sizeof (char *)); stackp = stackx + (stackp - stackb); stacke = stackx + 2 * (stacke - stackb); stackb = stackx; } *stackp++ = 0; *stackp++ = 0; goto nofinalize; case wordbound: if (d == string1 /* Points to first char */ || d == end2 /* Points to end */ || (d == end1 && size2 == 0)) /* Points to end */ break; if ((SYNTAX (d[-1]) == Sword) != (SYNTAX (d == end1 ? *string2 : *d) == Sword)) break; goto fail; case notwordbound: if (d == string1 /* Points to first char */ || d == end2 /* Points to end */ || (d == end1 && size2 == 0)) /* Points to end */ goto fail; if ((SYNTAX (d[-1]) == Sword) != (SYNTAX (d == end1 ? *string2 : *d) == Sword)) goto fail; break; case wordbeg: if (d == end2 /* Points to end */ || (d == end1 && size2 == 0) /* Points to end */ || SYNTAX (* (d == end1 ? string2 : d)) != Sword) /* Next char not a letter */ goto fail; if (d == string1 /* Points to first char */ || SYNTAX (d[-1]) != Sword) /* prev char not letter */ break; goto fail; case wordend: if (d == string1 /* Points to first char */ || SYNTAX (d[-1]) != Sword) /* prev char not letter */ goto fail; if (d == end2 /* Points to end */ || (d == end1 && size2 == 0) /* Points to end */ || SYNTAX (d == end1 ? *string2 : *d) != Sword) /* Next char not a letter */ break; goto fail;#ifdef emacs case before_dot: if (((d - string2 <= (unsigned) size2) ? d - bf_p2 : d - bf_p1) <= point) goto fail; break; case at_dot: if (((d - string2 <= (unsigned) size2) ? d - bf_p2 : d - bf_p1) == point) goto fail; break; case after_dot: if (((d - string2 <= (unsigned) size2) ? d - bf_p2 : d - bf_p1) >= point) goto fail; break; case wordchar: mcnt = (int) Sword; goto matchsyntax; case syntaxspec: mcnt = *p++; matchsyntax: PREFETCH; if (SYNTAX (*d++) != (enum syntaxcode) mcnt) goto fail; break; case notwordchar: mcnt = (int) Sword; goto matchnotsyntax; case notsyntaxspec: mcnt = *p++; matchnotsyntax: PREFETCH; if (SYNTAX (*d++) == (enum syntaxcode) mcnt) goto fail; break;#else case wordchar: PREFETCH; if (SYNTAX (*d++) == 0) goto fail; break; case notwordchar: PREFETCH; if (SYNTAX (*d++) != 0) goto fail; break;#endif /* not emacs */ case begbuf: if (d == string1) /* Note, d cannot equal string2 */ break; /* unless string1 == string2. */ goto fail; case endbuf: if (d == end2 || (d == end1 && size2 == 0)) break; goto fail; case exactn: /* Match the next few pattern characters exactly. mcnt is how many characters to match. */ mcnt = *p++; if (translate) { do { PREFETCH; if (translate[*d++] != *p++) goto fail; } while (--mcnt); } else { do { PREFETCH; if (*d++ != *p++) goto fail; } while (--mcnt); } break; } continue; /* Successfully matched one pattern command; keep matching */ /* Jump here if any matching operation fails. */ fail: if (stackp != stackb) /* A restart point is known. Restart there and pop it. */ { if (!stackp[-2]) { /* If innermost failure point is dormant, flush it and keep looking */ stackp -= 2; goto fail; } d = *--stackp; p = *--stackp; if (d >= string1 && d <= end1) dend = end_match_1; } else break; /* Matching at this starting point really fails! */ } return -1; /* Failure to match */}static intbcmp_translate (s1, s2, len, translate) unsigned char *s1, *s2; register int len; unsigned char *translate;{ register unsigned char *p1 = s1, *p2 = s2; while (len) { if (translate [*p1++] != translate [*p2++]) return 1; len--; } return 0;} /* Entry points compatible with bsd4.2 regex library */#ifndef emacsstatic struct re_pattern_buffer re_comp_buf;char *re_comp (s) char *s;{ if (!s) { if (!re_comp_buf.buffer) return "No previous regular expression"; return 0; } if (!re_comp_buf.buffer) { if (!(re_comp_buf.buffer = (char *) malloc (200))) return "Memory exhausted"; re_comp_buf.allocated = 200; if (!(re_comp_buf.fastmap = (char *) malloc (1 << BYTEWIDTH))) return "Memory exhausted"; } return re_compile_pattern (s, strlen (s), &re_comp_buf);}intre_exec (s) char *s;{ int len = strlen (s); return 0 <= re_search (&re_comp_buf, s, len, 0, len, 0);}#endif /* emacs */ #ifdef test#include <stdio.h>/* Indexed by a character, gives the upper case equivalent of the character */static char upcase[0400] = { 000, 001, 002, 003, 004, 005, 006, 007, 010, 011, 012, 013, 014, 015, 016, 017, 020, 021, 022, 023, 024, 025, 026, 027, 030, 031, 032, 033, 034, 035, 036, 037, 040, 041, 042, 043, 044, 045, 046, 047, 050, 051, 052, 053, 054, 055, 056, 057, 060, 061, 062, 063, 064, 065, 066, 067, 070, 071, 072, 073, 074, 075, 076, 077, 0100, 0101, 0102, 0103, 0104, 0105, 0106, 0107, 0110, 0111, 0112, 0113, 0114, 0115, 0116, 0117, 0120, 0121, 0122, 0123, 0124, 0125, 0126, 0127, 0130, 0131, 0132, 0133, 0134, 0135, 0136, 0137, 0140, 0101, 0102, 0103, 0104, 0105, 0106, 0107, 0110, 0111, 0112, 0113, 0114, 0115, 0116, 0117, 0120, 0121, 0122, 0123, 0124, 0125, 0126, 0127, 0130, 0131, 0132, 0173, 0174, 0175, 0176, 0177, 0200, 0201, 0202, 0203, 0204, 0205, 0206, 0207, 0210, 0211, 0212, 0213, 0214, 0215, 0216, 0217, 0220, 0221, 0222, 0223, 0224, 0225, 0226, 0227, 0230, 0231, 0232, 0233, 0234, 0235, 0236, 0237, 0240, 0241, 0242, 0243, 0244, 0245, 0246, 0247, 0250, 0251, 0252, 0253, 0254, 0255, 0256, 0257, 0260, 0261, 0262, 0263, 0264, 0265, 0266, 0267, 0270, 0271, 0272, 0273, 0274, 0275, 0276, 0277, 0300, 0301, 0302, 0303, 0304, 0305, 0306, 0307, 0310, 0311, 0312, 0313, 0314, 0315, 0316, 0317, 0320, 0321, 0322, 0323, 0324, 0325, 0326, 0327, 0330, 0331, 0332, 0333, 0334, 0335, 0336, 0337, 0340, 0341, 0342, 0343, 0344, 0345, 0346, 0347, 0350, 0351, 0352, 0353, 0354, 0355, 0356, 0357, 0360, 0361, 0362, 0363, 0364, 0365, 0366, 0367, 0370, 0371, 0372, 0373, 0374, 0375, 0376, 0377 };main (argc, argv) int argc; char **argv;{ char pat[80]; struct re_pattern_buffer buf; int i; char c; char fastmap[(1 << BYTEWIDTH)]; /* Allow a command argument to specify the style of syntax. */ if (argc > 1) obscure_syntax = atoi (argv[1]); buf.allocated =
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:e?grep ƒ:regex.c
+++++ Continued from previous card +++++
40; buf.buffer = (char *) malloc (buf.allocated); buf.fastmap = fastmap; buf.translate = upcase; while (1) { gets (pat); if (*pat) { re_compile_pattern (pat, strlen(pat), &buf); for (i = 0; i < buf.used; i++) printchar (buf.buffer[i]); putchar ('\n'); printf ("%d allocated, %d used.\n", buf.allocated, buf.used); re_compile_fastmap (&buf); printf ("Allowed by fastmap: "); for (i = 0; i < (1 << BYTEWIDTH); i++) if (fastmap[i]) printchar (i); putchar ('\n'); } gets (pat); /* Now read the string to match against */ i = re_match (&buf, pat, strlen (pat), 0, 0); printf ("Match value %d.\n", i); }}#ifdef NOTDEFprint_buf (bufp) struct re_pattern_buffer *bufp;{ int i; printf ("buf is :\n----------------\n"); for (i = 0; i < bufp->used; i++) printchar (bufp->buffer[i]); printf ("\n%d allocated, %d used.\n", bufp->allocated, bufp->used); printf ("Allowed by fastmap: "); for (i = 0; i < (1 << BYTEWIDTH); i++) if (bufp->fastmap[i]) printchar (i); printf ("\nAllowed by translate: "); if (bufp->translate) for (i = 0; i < (1 << BYTEWIDTH); i++) if (bufp->translate[i]) printchar (i); printf ("\nfastmap is%s accurate\n", bufp->fastmap_accurate ? "" : "n't"); printf ("can %s be null\n----------", bufp->can_be_null ? "" : "not");}#endifprintchar (c) char c;{ if (c < 041 || c >= 0177) { putchar ('\\'); putchar (((c >> 6) & 3) + '0'); putchar (((c >> 3) & 7) + '0'); putchar ((c & 7) + '0'); } else putchar (c);}error (string) char *string;{ puts (string); exit (1);}#endif /* test */ :MPW:MPW Tools:Tools with Source:e?grep ƒ:regex.h
/* Definitions for data structures callers pass the regex library. Copyright (C) 1985 Free Software Foundation, Inc. NO WARRANTY BECAUSE THIS PROGRAM IS LICENSED FREE OF CHARGE, WE PROVIDE ABSOLUTELYNO WARRANTY, TO THE EXTENT PERMITTED BY APPLICABLE STATE LAW. EXCEPTWHEN OTHERWISE STATED IN WRITING, FREE SOFTWARE FOUNDATION, INC,RICHARD M. STALLMAN AND/OR OTHER PARTIES PROVIDE THIS PROGRAM "AS IS"WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING,BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY ANDFITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITYAND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVEDEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR ORCORRECTION. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW WILL RICHARD M.STALLMAN, THE FREE SOFTWARE FOUNDATION, INC., AND/OR ANY OTHER PARTYWHO MAY MODIFY AND REDISTRIBUTE THIS PROGRAM AS PERMITTED BELOW, BELIABLE TO YOU FOR DAMAGES, INCLUDING ANY LOST PROFITS, LOST MONIES, OROTHER SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THEUSE OR INABILITY TO USE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA ORDATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY THIRD PARTIES ORA FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS) THISPROGRAM, EVEN IF YOU HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCHDAMAGES, OR FOR ANY CLAIM BY ANY OTHER PARTY. GENERAL PUBLIC LICENSE TO COPY 1. You may copy and distribute verbatim copies of this source fileas you receive it, in any medium, provided that you conspicuously andappropriately publish on each copy a valid copyright notice "Copyright(C) 1985 Free Software Foundation, Inc."; and include following thecopyright notice a verbatim copy of the above disclaimer of warrantyand of this License. You may charge a distribution fee for thephysical act of transferring a copy. 2. You may modify your copy or copies of this source file orany portion of it, and copy and distribute such modifications underthe terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains or is a derivative of this program or any part thereof, to be licensed at no charge to all third parties on terms identical to those contained in this License Agreement (except that you may choose to grant more extensive warranty protection to some or all third parties, at your option). c) You may charge a distribution fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee.Mere aggregation of another unrelated program with this program (or itsderivative) on a volume of a storage or distribution medium does not bringthe other program under the scope of these terms. 3. You may copy and distribute this program (or a portion or derivativeof it, under Paragraph 2) in object code or executable form under the termsof Paragraphs 1 and 2 above provided that you also do one of the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal shipping charge) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.)For an executable file, complete source code means all the source code forall modules it contains; but, as a special exception, it need not includesource code for modules which are standard libraries that accompany theoperating system on which the executable file runs. 4. You may not copy, sublicense, distribute or transfer this programexcept as expressly provided under this License Agreement. Any attemptotherwise to copy, sublicense, distribute or transfer this program is void andyour rights to use the program under this License agreement shall beautomatically terminated. However, parties who have received computersoftware programs from you with this License Agreement will not havetheir licenses terminated so long as such parties remain in full compliance. 5. If you wish to incorporate parts of this program into other freeprograms whose distribution conditions are different, write to the FreeSoftware Foundation at 675 Mass Ave, Cambridge, MA 02139. We have not yetworked out a simple rule that can be stated here, but we will often permitthis. We will be guided by the two goals of preserving the free status ofall derivatives of our free software and of promoting the sharing and reuse ofsoftware.In other words, you are welcome to use, share and improve this program.You are forbidden to forbid anyone else to use, share and improvewhat you give them. Help stamp out software-hoarding! *//* Prominent notice: This file modified 2/89 for MPW compatibility by Scott Lindsey, <scott@claris.com> *//* Define number of parens for which we record the beginnings and ends. This affects how much space the `struct re_registers' type takes up. */#ifndef RE_NREGS#define RE_NREGS 10#endif/* These bits are used in the obscure_syntax variable to choose among alternative regexp syntaxes. *//* 1 means plain parentheses serve as grouping, and backslash parentheses are needed for literal searching. 0 means backslash-parentheses are grouping, and plain parentheses are for literal searching. */#define RE_NO_BK_PARENS 1/* 1 means plain | serves as the "or"-operator, and \| is a literal. 0 means \| serves as the "or"-operator, and | is a literal. */#define RE_NO_BK_VBAR 2/* 0 means plain + or ? serves as an operator, and \+, \? are literals. 1 means \+, \? are operators and plain +, ? are literals. */#define RE_BK_PLUS_QM 4/* 1 means | binds tighter than ^ or $. 0 means the contrary. */#define RE_TIGHT_VBAR 8/* 1 means treat \n as an _OR operator 0 means trs a normal character */#define RE_NEWLINE_OR 16/* 0 means that a special characters (such as *, ^, and $) always have their special meaning regardless of the surrounding context. 1 means that special characters may act as normal characters in some contexts. Specifically, this applies to: ^ - only special at the beginning, or after ( or | $ - only special at the end, or before ) or | *, +, ? - only special when not after the beginning, (, or | */#define RE_CONTEXT_INDEP_OPS 32/* Now define combinations of bits for the standard possibilities. */#define RE_SYNTAX_AWK (RE_NO_BK_PARENS | RE_NO_BK_VBAR | RE_CONTEXT_INDEP_OPS)#define RE_SYNTAX_EGREP (RE_SYNTAX_AWK | RE_NEWLINE_OR)#define RE_SYNTAX_GREP (RE_BK_PLUS_QM | RE_NEWLINE_OR)#define RE_SYNTAX_EMACS 0/* This data structure is used to represent a compiled pattern. */struct re_pattern_buffer { char *buffer; /* Space holding the compiled pattern commands. */ int allocated; /* Size of space that buffer points to */ int used; /* Length of portion of buffer actually occupied */ char *fastmap; /* Pointer to fastmap, if any, or zero if none. */ /* re_search uses the fastmap, if there is one, to skip quickly over totally implausible characters */ char *translate; /* Translate table to apply to all characters before comparing. Or zero for no translation. The translation is applied to a pattern when it is compiled and to data when it is matched. */ char fastmap_accurate; /* Set to zero when a new pattern is stored, set to one when the fastmap is updated from it. */ char can_be_null; /* Set to one by compiling fastmap if this pattern might match the null string. It does not necessarily match the null string in that case, but if this is zero, it cannot. 2 as value means can match null string but at end of range or before a character listed in the fastmap. */ };/* Structure to store "register" contents data in. Pass the address of such a structure as an argument to re_match, etc., if you want this information back. start[i] and end[i] record the string matched by \( ... \) grouping i, for i from 1 to RE_NREGS - 1. start[0] and end[0] record the entire string matched. */struct re_registers { int start[RE_NREGS]; int end[RE_NREGS]; };/* These are the command codes that appear in compiled regular expressions, one per byte. Some command codes are followed by argument bytes. A command code can specify any interpretation whatever for its arguments. Zero-bytes may appear in the compiled regular expression. */enum regexpcode { unused, exactn, /* followed by one byte giving n, and then by n literal bytes */ begline, /* fails unless at beginning of line */ endline, /* fails unless at end of line */ jump, /* followed by two bytes giving relative address to jump to */ on_failure_jump, /* followed by two bytes giving relative address of place to resume at in case of failure. */ finalize_jump, /* Throw away latest failure point and then jump to address. */ maybe_finalize_jump, /* Like jump but finalize if safe to do so. This is used to jump back to the beginning of a repeat. If the command that follows this jump is clearly incompatible with the one at the beginning of the repeat, such that we can be sure that there is no use backtracking out of repetitions already completed, then we finalize. */ dummy_failure_jump, /* jump, and push a dummy failure point. This failure point will be thrown away if an attempt is made to use it for a failure. A + construct makes this before the first repeat. */ anychar, /* matches any one character */ charset, /* matches any one char belonging to specified set. First following byte is # bitmap bytes. Then come bytes for a bit-map saying which chars are in. Bits in each byte are ordered low-bit-first. A character is in the set if its bit is 1. A character too large to have a bit in the map is automatically not in the set */ charset_not, /* similar but match any character that is NOT one of those specified */ start_memory, /* starts remembering the text that is matched and stores it in a memory register. followed by one byte containing the register number. Register numbers must be in the range 0 through NREGS. */ stop_memory, /* stops remembering the text that is matched and stores it in a memory register. followed by one byte containing the register number. Register numbers must be in the range 0 through NREGS. */ duplicate, /* match a duplicate of something remembered. Followed by one byte containing the index of the memory register. */ before_dot, /* Succeeds if before dot */ at_dot, /* Succeeds if at dot */ after_dot, /* Succeeds if after dot */ begbuf, /* Succeeds if at beginning of buffer */ endbuf, /* Succeeds if at end of buffer */ wordchar, /* Matches any word-constituent character */ notwordchar, /* Matches any char that is not a word-constituent */ wordbeg, /* Succeeds if at word beginning */ wordend, /* Succeeds if at word end */ wordbound, /* Succeeds if at a word boundary */ notwordbound, /* Succeeds if not at a word boundary */ syntaxspec, /* Matches any character whose syntax is specified. followed by a byte which contains a syntax code, Sword or such like */ notsyntaxspec /* Matches any character whose syntax differs from the specified. */ }; extern char *re_compile_pattern ();/* Is this really advertised? */extern void re_compile_fastmap ();extern int re_search (), re_search_2 ();extern int re_match (), re_match_2 ();/* 4.2 bsd compatibility (yuck) */extern char *re_comp ();extern int re_exec ();#ifdef SYNTAX_TABLEextern char *re_syntax_table;#endif :MPW:MPW Tools:Tools with Source:e?grep ƒ:tests:khadafy.lines
1) Muammar Qaddafi2) Mo'ammar Gadhafi3) Muammar Kaddafi4) Muammar Qadhafi5) Moammar El Kadhafi6) Muammar Gadafi7) Mu'ammar al-Qadafi8) Moamer El Kazzafi9) Moamar al-Gaddafi10) Mu'ammar Al Qathafi11) Muammar Al Qathafi12) Mo'ammar el-Gadhafi13) Moamar El Kadhafi14) Muammar al-Qadhafi15) Mu'ammar al-Qadhdhafi16) Mu'ammar Qadafi17) Moamar Gaddafi18) Mu'ammar Qadhdhafi19) Muammar Khaddafi20) Muammar al-Khaddafi21) Mu'amar al-Kadafi22) Muammar Ghaddafy23) Muammar Ghadafi24) Muammar Ghaddafi25) Muamar Kaddafi26) Muammar Quathafi27) Muammar Gheddafi28) Muamar Al-Kaddafi29) Moammar Khadafy30) Moammar Qudhafi31) Mu'ammar al-Qaddafi32) Mulazim Awwal Mu'ammar Muhammad Abu Minyar al-Qadhafi :MPW:MPW Tools:Tools with Source:e?grep ƒ:tests:khadafy.regexp
M[ou]'¿am+[ae]r ≈([AEae]l[- ])¿[GKQ]h¿[aeu]+([dtz][dhz]¿)+af[iy] :MPW:MPW Tools:Tools with Source:e?grep ƒ:tests:regress.sh
0:abc:abc1:abc:xbc1:abc:axc1:abc:abx0:abc:xabcy0:abc:ababc0:ab*c:abc0:ab*bc:abc0:ab*bc:abbc0:ab*bc:abbbbc0:ab+bc:abbc1:ab+bc:abc1:ab+bc:abq0:ab+bc:abbbbc0:ab¿bc:abbc0:ab¿bc:abc1:ab¿bc:abbbbc0:ab¿c:abc0:•abc∞:abc1:•abc∞:abcc0:•abc:abcc1:•abc∞:aabc0:abc∞:aabc0:•:abc0:∞:abc0:a?c:abc0:a?c:axc0:a≈c:axyzc1:a≈c:axyzd1:a[bc]d:abc0:a[bc]d:abd1:a[b-d]e:abd0:a[b-d]e:ace0:a[b-d]:aac0:a[-b]:a-2:a[b-]:a-1:a[b-a]:-2:a[]b:-2:a[:-0:a]:a]0:a[]]b:a]b0:a[¬bc]d:aed1:a[¬bc]d:abd0:a[¬-b]c:adc1:a[¬-b]c:a-c1:a[¬]b]c:a]c0:a[¬]b]c:adc0:ab|cd:abc0:ab|cd:abcd0:()ef:def0:()*:-1:*a:-0:•*:-0:∞*:-1:(*)b:-1:∞b:b2:a∂∂:-0:a∂∂(b:a(b0:a∂∂(*b:ab0:a∂∂(*b:a((b1:a∂∂x:a∂∂x2:abc):-2:(abc:-0:((a)):abc0:(a)b(c):abc0:a+b+c:aabbabc0:a**:-0:a*¿:-0:(a*)*:-0:(a*)+:-0:(a|)*:-0:(a*|b)*:-0:(a+|b)*:ab0:(a+|b)+:ab0:(a+|b)¿:ab0:[¬ab]*:cde0:(•)*:-0:(ab|)*:-2:)(:-1:abc:1:abc:0:a*:0:([abc])*d:abbbcd0:([abc])*bcd:abcd0:a|b|c|d|e:e0:(a|b|c|d|e)f:ef0:((a*|b))*:-0:abcd*efg:abcdefg0:ab*:xabyabbbz0:ab*:xayabbbz0:(ab|cd)e:abcde0:[abhgefdc]ij:hij1:•(ab|cd)e:abcde0:(abc|)ef:abcdef0:(a|b)c*d:abcd0:(ab|ab*)bc:abc0:a([bc]*)c*:abc0:a([bc]*)(c*d):abcd0:a([bc]+)(c*d):abcd0:a([bc]*)(c+d):abcd0:a[bcd]*dcdcde:adcdcde1:a[bcd]+dcdcde:adcdcde0:(ab|a)b*c:abc0:((a)(b)c)(d):abcd0:[A-Za-z_][A-Za-z0-9_]*:alpha0:•a(bc+|b[eh])g|?h∞:abh0:(bc+d∞|ef*g?|h¿i(j|k)):effgz0:(bc+d∞|ef*g?|h¿i(j|k)):ij1:(bc+d∞|ef*g?|h¿i(j|k)):effg1:(bc+d∞|ef*g?|h¿i(j|k)):bcdd0:(bc+d∞|ef*g?|h¿i(j|k)):reffgz1:((((((((((a)))))))))):-0:(((((((((a))))))))):a1:multiple words of text:uh-uh0:multiple words:multiple words, yeah0:(≈)c(≈):abcde1:∂∂((≈),:(≈)∂∂)1:[k]:ab0:abcd:abcd0:a(bc)d:abcd0:a[-]¿c:ac0:(????)≈®1:beriberi :MPW:MPW Tools:Tools with Source:Envs ƒ:Env.c
# include <StdIO.h>main (argc, argv, envp) int argc ; char *argv[] ; char *envp[] ;{ while (*argv != 0) printf ("%s\n", *argv++) ; printf ("\n") ; while (*envp != 0) { printf ("%15s = %s\n", *envp, getenv (*envp)) ; envp++ ; } return (0) ;} :MPW:MPW Tools:Tools with Source:Envs ƒ:Env.make
## This makefile builds the Env utility.#Env.c.o ƒ Env.c C Env.cEnv ƒ Env.c.o Link Env.c.o ∂ "{CLibraries}"CInterface.o ∂ "{CLibraries}"StdCLib.o ∂ "{CLibraries}"CSANELib.o ∂ "{CLibraries}"CRuntime.o ∂ -c "MPS " -t "MPST" ∂ -o {Tools}Env :MPW:MPW Tools:Tools with Source:EventDisplay ƒ:EventDisplay.c
/* EventDisplay Matthew J. Snyder 71450,2606@compuserve.com When invoked, EventDisplay will display events until a 'q' is typed.*/#include <stdio.h>#include <Events.h>#include <QuickDraw.h>main() {EventRecord myEvent;printf("Type Q to quit\n\n");fflush(stdout);do { if (GetNextEvent((short)everyEvent, &myEvent)) { printf(" what -> %X\n", myEvent.what); printf(" message -> %lX\n", myEvent.message); printf(" when -> %lX\n", myEvent.when); printf(" where-h -> %X\n", myEvent.where.h); printf(" where-v -> %X\n", myEvent.where.h); printf("modifiers -> %X\n", myEvent.modifiers); printf("\n"); } else myEvent.message = 0; /* in case it's garbage */ } while ((int)(myEvent.message&charCodeMask) != 'Q'); } /* main() */ :MPW:MPW Tools:Tools with Source:EventDisplay ƒ:EventDisplay.make
/* FAccess.c * * MPW tool to set/return file status information */ #include <Types.h>#include <FCntl.h>#include <StdIo.h>#include <StdLib.h>/* selection record definition */struct SelectRect { long startingPos; long endingPos; long displayTop; }; /* SelectRect */ void main(int argc,char **argv){char *fileName,*optName;int retVal;long tempLong;struct SelectRect tempSelection;Rect tempRect;optName = *(argv + 1);fileName = *(argv + 2);switch (*(optName + 1)) { case 't' : { /* get tab information */ retVal = faccess(fileName,F_GTABINFO,&tempLong); (void) printf("%ld\n",tempLong); break; } /* case 't' */ case 'T' : { /* set tab information */ tempLong = atol(*(argv + 3)); retVal = faccess(fileName,F_STABINFO,(long *)tempLong); break; } /* case 'T' */ case 'f' : { /* get font information */ retVal = faccess(fileName,F_GFONTINFO,&tempLong); (void) printf("%ld\n",tempLong); break; } /* case 'f' */ case 'F' : { /* set font information */ tempLong = atol(*(argv + 3)); retVal = faccess(fileName,F_SFONTINFO,(long *)tempLong); break; } /* case 'F' */ case 's' : { /* get selection information */ retVal = faccess(fileName,F_GSELINFO,(long *)&tempSelection); (void) printf("%ld %ld %ld\n",tempSelection.startingPos,tempSelection.endingPos,tempSelection.displayTop); break; } /* case 's' */ case 'S' : { /* set selection information */ tempSelection.startingPos = atol(*(argv + 3)); tempSelection.endingPos = atol(*(argv + 4)); tempSelection.displayTop = atol(*(argv + 5)); retVal = faccess(fileName,F_SSELINFO,(long *)&tempSelection); break; } /* case 'S' */ case 'w' : { /* get window position information */ retVal = faccess(fileName,F_GWININFO,(long *)&tempRect); (void) printf("%d %d %d %d\n",tempRect.top,tempRect.left,tempRect.bottom,tempRect.right); break; } /* case 'w' */ case 'W' : { /* set window position information */ tempRect.top = atoi(*(argv + 3)); tempRect.left = atoi(*(argv + 4)); tempRect.bottom = atoi(*(argv + 5)); tempRect.right = atoi(*(argv + 6)); retVal = faccess(fileName,F_SWININFO,(long *)&tempRect); break; } /* case 'W' */ default : { (void) fprintf(stderr,"#Usage: FAccess [-t -T -f -F -s -S -w -W] Filename\n"); retVal = 1; break; } /* default */ } /* switch *optName */exit(retVal);} /* main() *//* end of FAccess.c */ :MPW:MPW Tools:Tools with Source:FAccessƒ:NewClose
# NewClose - close (and optionally save and backup) file scriptSet SaveExit {Exit}Set Exit 0Set NFile {#} # get number of command line argumentsUnalias CloseIf ({NFile} == 0) # no arguments - close active window Confirm -t "Save changes to {Active}" Set ConfirmStatus {Status} Set OldName "`Quote -n {Active}`" ∑∑ Dev:Null # save the current window name If ({ConfirmStatus} == 0) Set OldTab "`FAccess -t "{OldName}"`" ∑∑ Dev:Null # save the current window tab setting Set OldFont "`FAccess -f "{OldName}"`" ∑∑ Dev:Null # save the current window font setting Set OldSelect "`FAccess -s "{OldName}"`" ∑∑ Dev:Null # save the current window selection Set OldWindow "`FAccess -w "{OldName}"`" ∑∑ Dev:Null # save the current window position Set TempName "{OldName}".tmp Duplicate -y "{OldName}" "{TempName}" ∑∑ Dev:Null # duplicate the current file Open "{TempName}" ∑∑ Dev:Null # open the copy of the current file Close -n "{OldName}" ∑∑ Dev:Null # get the original version of the file, and close it Move -y "{OldName}" "{Backup}" ∑∑ Dev:Null # move it to the backup directory Rename -y "{TempName}" "{OldName}" ∑∑ Dev:Null # restore the original name FAccess -T "{OldName}" {OldTab} ≥≥ Dev:Null # restore the original tab setting FAccess -F "{OldName}" {OldFont} ≥≥ Dev:Null # restore the original font setting FAccess -S "{OldName}" {OldSelect} ≥≥ Dev:Null # restore the original selection FAccess -W "{OldName}" {OldWindow} ≥≥ Dev:Null # restore the original position Close "{OldName}" Else If ({ConfirmStatus} == 4) Close -n "{OldName}" End EndElse Loop Break If ({NFile} == 0) # exit if all arguments have been processed If (`Exists -f "{1}"` <> "") # Does the file exist? # Check to see if the file is already open within MPW Copy § "{1}" ∑∑ Dev:Null Set IsOpen {Status} If ({IsOpen} == 0) # the file is open Confirm -t "Save changes to "{1}"" Set ConfirmStatus {Status} If ({ConfirmStatus} == 0) Set OldTab "`FAccess -t "{1}"`" ∑∑ Dev:Null # save the current window tab setting Set OldFont "`FAccess -f "{1}"`" ∑∑ Dev:Null # save the current window font setting Set OldSelect "`FAccess -s "{1}"`" ∑∑ Dev:Null # save the current window selection Set OldWindow "`FAccess -w "{1}"`" ∑∑ Dev:Null # save the current window position Set TempName "{1}".tmp Duplicate -y "{1}" "{TempName}" ∑∑ Dev:Null # duplicate the current file Open "{TempName}" ∑∑ Dev:Null # open the copy of the current file Close -n "{1}" ∑∑ Dev:Null # get the original version of the file, and close it Move -y "{1}" "{Backup}" ∑∑ Dev:Null # move it to the backup directory Rename -y "{TempName}" "{1}" ∑∑ Dev:Null # restore the original name FAccess -T "{1}" {OldTab} ≥≥ Dev:Null # restore the original tab setting FAccess -F "{1}" {OldFont} ≥≥ Dev:Null # restore the original font setting FAccess -S "{1}" {OldSelect} ≥≥ Dev:Null # restore the original selection FAccess -W "{1}" {OldWindow} ≥≥ Dev:Null # restore the original position Close "{1}" Else If ({ConfirmStatus} == 4) Close -n "{1}" End End End End Shift 1 # go to next argument Evaluate NFile -= 1 # update argument counter EndEndSet Exit {SaveExit} :MPW:MPW Tools:Tools with Source:FAccessƒ:NewSave
# NewSave - save and backup file scriptSet NFile {#} # get number of command line argumentsUnalias OpenUnalias CloseUnalias SaveIf ({NFile} == 0) # no arguments - save active window Set OldName "`Quote {Active}`" ∑∑ Dev:Null # save the current window name Set OldTab "`FAccess -t "{OldName}"`" ∑∑ Dev:Null # save the current window tab setting Set OldFont "`FAccess -f "{OldName}"`" ∑∑ Dev:Null # save the current window font setting Set OldSelect "`FAccess -s "{OldName}"`" ∑∑ Dev:Null # save the current window selection Set OldWindow "`FAccess -w "{OldName}"`" ∑∑ Dev:Null # save the current window position Set TempName "{OldName}".tmp Duplicate -y "{OldName}" "{TempName}" ∑∑ Dev:Null # duplicate the current file Open "{TempName}" ∑∑ Dev:Null # open the copy of the current file Close -n "{OldName}" ∑∑ Dev:Null # get the original version of the file, and close it Move -y "{OldName}" "{Backup}" ∑∑ Dev:Null # move it to the backup directory Rename -y "{TempName}" "{OldName}" ∑∑ Dev:Null # restore the original name FAccess -T "{OldName}" {OldTab} ≥≥ Dev:Null # restore the original tab setting FAccess -F "{OldName}" {OldFont} ≥≥ Dev:Null # restore the original font setting FAccess -S "{OldName}" {OldSelect} ≥≥ Dev:Null # restore the original selection FAccess -W "{OldName}" {OldWindow} ≥≥ Dev:Null # restore the original positionElse Loop Break If ({NFile} == 0) # exit if all arguments have been processed If (`Exists -f "{1}"` <> "") # Does the file exist? # Check to see if the file is already open within MPW Copy § "{1}" ∑∑ Dev:Null Set IsOpen {Status} If ({IsOpen} == 0) # the file is open Set OldTab "`FAccess -t "{1}"`" ∑∑ Dev:Null # save the current window tab setting Set OldFont "`FAccess -f "{1}"`" ∑∑ Dev:Null # save the current window font setting Set OldSelect "`FAccess -s "{1}"`" ∑∑ Dev:Null # save the current window selection Set OldWindow "`FAccess -w "{1}"`" ∑∑ Dev:Null # save the current window position Set TempName "{1}".tmp Duplicate -y "{1}" "{TempName}" ∑∑ Dev:Null # duplicate the current file Open "{TempName}" ∑∑ Dev:Null # open the copy of the current file Close -n "{1}" ∑∑ Dev:Null # get the original version of the file, and close it Move -y "{1}" "{Backup}" ∑∑ Dev:Null # move it to the backup directory Rename -y "{TempName}" "{1}" ∑∑ Dev:Null # restore the original name FAccess -T "{1}" {OldTab} ≥≥ Dev:Null # restore the original tab setting FAccess -F "{1}" {OldFont} ≥≥ Dev:Null # restore the original font setting FAccess -S "{1}" {OldSelect} ≥≥ Dev:Null # restore the original selection FAccess -W "{1}" {OldWindow} ≥≥ Dev:Null # restore the original position End End Shift 1 # go to next argument Evaluate NFile -= 1 # update argument counter EndEnd :MPW:MPW Tools:Tools with Source:FAccessƒ:ReadMe
SPARSE DOCUMENTATION FOR MPW BACKUP AND SAVE ROUTINESThe included scripts NewSave and NewClose, and the associatedtool FAccess (source FAccess.c) may be used to implement a simple,but rather inelegant backup file before saving procedure.Background:As anyone who has unwittingly saved a file in MPW has surely noticed,MPW does not provide any means to save backup copies of files beingedited. In fact, it seems to go out of its way to prevent backupsfrom being made. Because MPW takes over the file system, there isno easy way to make of copy of an open file. Attempts to copy thefile using Duplicate or any home-grown MPW tool will instead save thecontents of the open window - including all the unsaved edits.Even this is not the whole story, however. If you create such aduplicate file, the open it, it will not "remember" the originalwindow's position, size, or markers. In many cases the formattingmay also be lost.So what:A solution to this dilemma is as follows.1) When saving a file, perform the following steps - duplicate the current file to a temp file - use the tool FAccess to save window status information - close the current file, DISCARDING ALL CHANGES - move this file to wherever backup files go, or rename it - open the duplicated file - set its status using FAccess and the saved status information2) When closing a file, do the above steps as necessary, then do a normal close. Included in this package are four files. NewSave - an MPW script which performs the above steps. It assumes there is an MPW environment variable {Backup} which is the folder pathname where backup files arev put. NewClose - ditto. FAccess - an MPW tool which returns the file status information required by NewSave and NewClose. FAccess.c - source code for above. The best way to use all this is probably to use AddMenu to addNewSave and NewClose to the File menu, with command key equivalentsas required. I used Command-S and -W, and used ResEdit to removethose key equivalents from the standard Save and Close. I thenused Alias to force most scripts to use the modified commands.If you do this, certain existing scripts may need to be modified(via Unalias) to use the standard Save and Close commands.Also, please note that at present the NewXXX scripts doe not supporta -A (all open windows) option. The scripts may be modified to dothis if you so please.The usual disclaimers hold. I tried to write perfect, bug-freecode, but I'm human and failable. If you lose data or your jobwhile using these commands, I'm sorry but not responsible.Brian ClarkCServe 71241,2407 :MPW:MPW Tools:Tools with Source:Fast LEX:alloca.a
;;;; Alloca() for Macintosh Programmer's Workshop C.;; alloca(n) allocates n bytes of storage in the stack;; frame of the caller.;; CASE ON alloca PROC EXPORT move.l (sp)+,a0 ; pop return address move.l (sp)+,d0 ; pop parameter = size in bytes add.l #3,d0 ; round size up to long word and.l #-4,d0 ; mask out lower two bits of size sub.l d0,sp ; allocate by moving stack pointer move.l sp,d0 ; return pointer add.l #-4,sp ; new top of stack jmp (a0) ; return to caller ENDP END :MPW:MPW Tools:Tools with Source:Fast LEX:bzero.c
bzero(x,size)char *x;int size;{ int i; for(i=0;i<size;i++){ *(x+i) = 0; }} :MPW:MPW Tools:Tools with Source:Fast LEX:ccl.c
/* ccl - routines for character classes *//* * Copyright (c) 1987, the University of California * * The United States Government has rights in this work pursuant to * contract no. DE-AC03-76SF00098 between the United States Department of * Energy and the University of California. * * This program may be redistributed. Enhancements and derivative works * may be created provided the new works, if made available to the general * public, are made available for use by anyone. */#include "flexdef.h"/* ccladd - add a single character to a ccl * * synopsis * int cclp; * char ch; * ccladd( cclp, ch ); */ccladd( cclp, ch )int cclp;char ch; { int ind, len, newpos, i; len = ccllen[cclp]; ind = cclmap[cclp]; /* check to see if the character is already in the ccl */ for ( i = 0; i < len; ++i ) if ( ccltbl[ind + i] == ch ) return; newpos = ind + len; if ( newpos >= current_max_ccl_tbl_size ) { current_max_ccl_tbl_size += MAX_CCL_TBL_SIZE_INCREMENT; ++num_reallocs; ccltbl = reallocate_character_array( ccltbl, current_max_ccl_tbl_size ); } ccllen[cclp] = len + 1; ccltbl[newpos] = ch; }/* cclinit - make an empty ccl * * synopsis * int cclinit(); * new_ccl = cclinit(); */int cclinit() { if ( ++lastccl >= current_maxccls ) { current_maxccls += MAXCCLS_INCREMENT; ++num_reallocs; cclmap = reallocate_integer_array( cclmap, current_maxccls ); ccllen = reallocate_integer_array( ccllen, current_maxccls ); cclng = reallocate_integer_array( cclng, current_maxccls ); } if ( lastccl == 1 ) /* we're making the first ccl */ cclmap[lastccl] = 0; else /* the new pointer is just past the end of the last ccl. Since * the cclmap points to the \first/ character of a ccl, adding the * length of the ccl to the cclmap pointer will produce a cursor * to the first free space */ cclmap[lastccl] = cclmap[lastccl - 1] + ccllen[lastccl - 1]; ccllen[lastccl] = 0; cclng[lastccl] = 0; /* ccl's start out life un-negated */ return ( lastccl ); }/* cclnegate - negate a ccl * * synopsis * int cclp; * cclnegate( ccl ); */cclnegate( cclp )int cclp; { cclng[cclp] = 1; } :MPW:MPW Tools:Tools with Source:Fast LEX:Cross Reference Demo:CrsRef.l
########################################################################## ## Make - CrsRef.make ## Purpose - This is the Cross Reference's make file. ## ##########################################################################CrsRef.c.o ƒ CrsRef.l FLEX -L CrsRef.l SetFile -t 'TEXT' -c 'MPS ' lex.yy.c C -o CrsRef.c.o lex.yy.c Delete -i lex.yy.cCrsRef ƒƒ CrsRef.c.o Link -w -c 'MPS ' -t MPST ∂ CrsRef.c.o ∂ "{Libraries}"stubs.o ∂ "{CLibraries}"CRuntime.o ∂ "{Libraries}"Interface.o ∂ "{CLibraries}"StdCLib.o ∂ "{CLibraries}"CSANELib.o ∂ "{CLibraries}"Math.o ∂ "{CLibraries}"CInterface.o ∂ "{Libraries}"ToolLibs.o ∂ -o CrsRef :MPW:MPW Tools:Tools with Source:Fast LEX:dfa.c
/* dfa - DFA construction routines *//* * Copyright (c) 1987, the University of California * * The United States Government has rights in this work pursuant to * contract no. DE-AC03-76SF00098 between the United States Department of * Energy and the University of California. * * This program may be redistributed. Enhancements and derivative works * may be created provided the new works, if made available to the general * public, are made available for use by anyone. */#include "flexdef.h"/* epsclosure - construct the epsilon closure of a set of ndfa states * * synopsis * int t[current_max_dfa_size], numstates, accset[accnum + 1], nacc; * int hashval; * int *epsclosure(); * t = epsclosure( t, &numstates, accset, &nacc, &hashval ); * * NOTES * the epsilon closure is the set of all states reachable by an arbitrary * number of epsilon transitions which themselves do not have epsilon * transitions going out, unioned with the set of states which have non-null * accepting numbers. t is an array of size numstates of nfa state numbers. * Upon return, t holds the epsilon closure and numstates is updated. accset * holds a list of the accepting numbers, and the size of accset is given * by nacc. t may be subjected to reallocation if it is not large enough * to hold the epsilon closure. * * hashval is the hash value for the dfa corresponding to the state set */int *epsclosure( t, ns_addr, accset, nacc_addr, hv_addr )int *t, *ns_addr, accset[], *nacc_addr, *hv_addr; { register int stkpos, ns, tsp; int numstates = *ns_addr, nacc, hashval, transsym, nfaccnum; int stkend, nstate; static int did_stk_init = false, *stk; #define MARK_STATE(state) \ trans1[state] = trans1[state] - MARKER_DIFFERENCE;#define IS_MARKED(state) (trans1[state] < 0)#define UNMARK_STATE(state) \ trans1[state] = trans1[state] + MARKER_DIFFERENCE;#define CHECK_ACCEPT(state) \ { \ nfaccnum = accptnum[state]; \ if ( nfaccnum != NIL ) \ accset[++nacc] = nfaccnum; \ }#define DO_REALLOCATION \ { \ current_max_dfa_size += MAX_DFA_SIZE_INCREMENT; \ ++num_reallocs; \ t = reallocate_integer_array( t, current_max_dfa_size ); \ stk = reallocate_integer_array( stk, current_max_dfa_size ); \ } \#define PUT_ON_STACK(state) \ { \ if ( ++stkend >= current_max_dfa_size ) \ DO_REALLOCATION \ stk[stkend] = state; \ MARK_STATE(state) \ }#define ADD_STATE(state) \ { \ if ( ++numstates >= current_max_dfa_size ) \ DO_REALLOCATION \ t[numstates] = state; \ hashval = hashval + state; \ }#define STACK_STATE(state) \ { \ PUT_ON_STACK(state) \ CHECK_ACCEPT(state) \ if ( nfaccnum != NIL || transchar[state] != SYM_EPSILON ) \ ADD_STATE(state) \ } if ( ! did_stk_init ) { stk = allocate_integer_array( current_max_dfa_size ); did_stk_init = true; } nacc = stkend = hashval = 0; for ( nstate = 1; nstate <= numstates; ++nstate ) { ns = t[nstate]; /* the state could be marked if we've already pushed it onto * the stack */ if ( ! IS_MARKED(ns) ) PUT_ON_STACK(ns) CHECK_ACCEPT(ns) hashval = hashval + ns; } for ( stkpos = 1; stkpos <= stkend; ++stkpos ) { ns = stk[stkpos]; transsym = transchar[ns]; if ( transsym == SYM_EPSILON ) { tsp = trans1[ns] + MARKER_DIFFERENCE; if ( tsp != NO_TRANSITION ) { if ( ! IS_MARKED(tsp) ) STACK_STATE(tsp) tsp = trans2[ns]; if ( tsp != NO_TRANSITION ) if ( ! IS_MARKED(tsp) ) STACK_STATE(tsp) } } } /* clear out "visit" markers */ for ( stkpos = 1; stkpos <= stkend; ++stkpos ) { if ( IS_MARKED(stk[stkpos]) ) { UNMARK_STATE(stk[stkpos]) } else flexfatal( "consistency check failed in epsclosure()" ); } *ns_addr = numstates; *hv_addr = hashval; *nacc_addr = nacc; return ( t ); }/* increase_max_dfas - increase the maximum number of DFAs */increase_max_dfas() { int old_max = current_max_dfas; current_max_dfas += MAX_DFAS_INCREMENT; ++num_reallocs; base = reallocate_integer_array( base, current_max_dfas ); def = reallocate_integer_array( def, current_max_dfas ); dfasiz = reallocate_integer_array( dfasiz, current_max_dfas ); accsiz = reallocate_integer_array( accsiz, current_max_dfas ); dhash = reallocate_integer_array( dhash, current_max_dfas ); todo = reallocate_integer_array( todo, current_max_dfas ); dss = reallocate_integer_pointer_array( dss, current_max_dfas ); dfaacc = reallocate_dfaacc_union( dfaacc, current_max_dfas ); /* fix up todo queue */ if ( todo_next < todo_head ) { /* queue was wrapped around the end */ register int i; for ( i = 0; i < todo_next; ++i ) todo[old_max + i] = todo[i]; todo_next += old_max; } }/* snstods - converts a set of ndfa states into a dfa state * * synopsis * int sns[numstates], numstates, newds, accset[accnum + 1], nacc, hashval; * int snstods(); * is_new_state = snstods( sns, numstates, accset, nacc, hashval, &newds ); * * on return, the dfa state number is in newds. */int snstods( sns, numstates, accset, nacc, hashval, newds_addr )int sns[], numstates, accset[], nacc, hashval, *newds_addr; { int didsort = 0; register int i, j; int newds, *oldsns; char *malloc(); for ( i = 1; i <= lastdfa; ++i ) if ( hashval == dhash[i] ) { if ( numstates == dfasiz[i] ) { oldsns = dss[i]; if ( ! didsort ) { /* we sort the states in sns so we can compare it to * oldsns quickly. we use bubble because there probably * aren't very many states */ bubble( sns, numstates ); didsort = 1; } for ( j = 1; j <= numstates; ++j ) if ( sns[j] != oldsns[j] ) break; if ( j > numstates ) { ++dfaeql; *newds_addr = i; return ( 0 ); } ++hshcol; } else ++hshsave; } /* make a new dfa */ if ( ++lastdfa >= current_max_dfas ) increase_max_dfas(); newds = lastdfa; if ( ! (dss[newds] = (int *) malloc( (unsigned) ((numstates + 1) * sizeof( int )) )) ) flexfatal( "dynamic memory failure in snstods()" ); /* if we haven't already sorted the states in sns, we do so now, so that * future comparisons with it can be made quickly */ if ( ! didsort ) bubble( sns, numstates ); for ( i = 1; i <= numstates; ++i ) dss[newds][i] = sns[i]; dfasiz[newds] = numstates; dhash[newds] = hashval; if ( nacc == 0 ) { dfaacc[newds].dfaacc_state = 0; accsiz[newds] = 0; } else if ( reject ) { /* we sort the accepting set in increasing order so the disambiguating * rule that the first rule listed is considered match in the event of * ties will work. We use a bubble sort since the list is probably * quite small. */ bubble( accset, nacc ); dfaacc[newds].dfaacc_state = (int) malloc( (unsigned) ((nacc + 1) * sizeof( int )) ); if ( ! dfaacc[newds].dfaacc_state ) flexfatal( "dynamic memory failure in snstods()" ); /* save the accepting set for later */ for ( i = 1; i <= nacc; ++i ) dfaacc[newds].dfaacc_set[i] = accset[i]; accsiz[newds] = nacc; } else { /* find lowest numbered rule so the disambiguating rule will work */ j = accnum + 1; for ( i = 1; i <= nacc; ++i ) if ( accset[i] < j ) j = accset[i]; dfaacc[newds].dfaacc_state = j; } *newds_addr = newds; return ( 1 ); }/* symfollowset - follow the symbol transitions one step * * synopsis * int ds[current_max_dfa_size], dsize, transsym; * int nset[current_max_dfa_size], numstates; * numstates = symfollowset( ds, dsize, transsym, nset ); */int symfollowset( ds, dsize, transsym, nset )int ds[], dsize, transsym, nset[]; { int ns, tsp, sym, i, j, lenccl, ch, numstates; int ccllist; numstates = 0; for ( i = 1; i <= dsize; ++i ) { /* for each nfa state ns in the state set of ds */ ns = ds[i]; sym = transchar[ns]; tsp = trans1[ns]; if ( sym < 0 ) { /* it's a character class */ sym = -sym; ccllist = cclmap[sym]; lenccl = ccllen[sym]; if ( cclng[sym] ) { for ( j = 0; j < lenccl; ++j ) { /* loop through negated character class */ ch = ccltbl[ccllist + j] & BYTEMASK; if ( ch > transsym ) break; /* transsym isn't in negated ccl */ else if ( ch == transsym ) /* next 2 */ goto bottom; } /* didn't find transsym in ccl */ nset[++numstates] = tsp; } else for ( j = 0; j < lenccl; ++j ) { ch = ccltbl[ccllist + j] & BYTEMASK; if ( ch > transsym ) break; else if ( ch == transsym ) { nset[++numstates] = tsp; break; } } } else if ( sym >= 'A' && sym <= 'Z' && caseins ) flexfatal( "consistency check failed in symfollowset" ); else if ( sym == SYM_EPSILON ) { /* do nothing */ } else if ( ecgroup[sym] == transsym ) nset[++numstates] = tsp;bottom: ; } return ( numstates ); }/* sympartition - partition characters with same out-transitions * * synopsis * integer ds[current_max_dfa_size], numstates, duplist[numecs]; * symlist[numecs]; * sympartition( ds, numstates, symlist, duplist ); */sympartition( ds, numstates, symlist, duplist )int ds[], numstates, duplist[];int symlist[]; { int tch, i, j, k, ns, dupfwd[CSIZE + 1], lenccl, cclp, ich; /* partitioning is done by creating equivalence classes for those * characters which have out-transitions from the given state. Thus * we are really creating equivalence classes of equivalence classes. */ for ( i = 1; i <= numecs; ++i ) { /* initialize equivalence class list */ duplist[i] = i - 1; dupfwd[i] = i + 1; } duplist[1] = NIL; dupfwd[numecs] = NIL; for ( i = 1; i <= numstates; ++i ) { ns = ds[i]; tch = transchar[ns]; if ( tch != SYM_EPSILON ) { if ( tch < -lastccl || tch > CSIZE ) flexfatal( "bad transition character detected in sympartition()" ); if ( tch > 0 ) { /* character transition */ mkechar( ecgroup[tch], dupfwd, duplist ); symlist[ecgroup[tch]] = 1; } else { /* character class */ tch = -tch; lenccl = ccllen[tch]; cclp = cclmap[tch]; mkeccl( ccltbl + cclp, lenccl, dupfwd, duplist, numecs ); if ( cclng[tch] ) { j = 0; for ( k = 0; k < lenccl; ++k ) { ich = ccltbl[cclp + k] & BYTEMASK; for ( ++j; j < ich; ++j ) symlist[j] = 1; } for ( ++j; j <= numecs; ++j ) symlist[j] = 1; } else for ( k = 0; k < lenccl; ++k ) { ich = ccltbl[cclp + k] & BYTEMASK; symlist[ich] = 1; } } } } } :MPW:MPW Tools:Tools with Source:Fast LEX:ecs.c
/* ecs - equivalence class routines *//* * Copyright (c) 1987, the University of California * * The United States Government has rights in this work pursuant to * contract no. DE-AC03-76SF00098 between the United States Department of * Energy and the University of California. * * This program may be redistributed. Enhancements and derivative works * may be created provided the new works, if made available to the general * public, are made available for use by anyone. */#include "flexdef.h"/* ccl2ecl - convert character classes to set of equivalence classes * * synopsis * ccl2ecl(); */ccl2ecl() { int i, ich, newlen, cclp, ccls, cclmec; for ( i = 1; i <= lastccl; ++i ) { /* we loop through each character class, and for each character * in the class, add the character's equivalence class to the * new "character" class we are creating. Thus when we are all * done, character classes will really consist of collections * of equivalence classes */ newlen = 0; cclp = cclmap[i]; for ( ccls = 0; ccls < ccllen[i]; ++ccls ) { ich = ccltbl[cclp + ccls] & BYTEMASK; cclmec = ecgroup[ich]; if ( cclmec > 0 ) { ccltbl[cclp + newlen] = cclmec; ++newlen; } } ccllen[i] = newlen; } }/* cre8ecs - associate equivalence class numbers with class members * * synopsis * int cre8ecs(); * number of classes = cre8ecs( fwd, bck, num ); * * fwd is the forward linked-list of equivalence class members. bck * is the backward linked-list, and num is the number of class members. * Returned is the number of classes. */int cre8ecs( fwd, bck, num )int fwd[], bck[], num; { int i, j, numcl; numcl = 0; /* create equivalence class numbers. From now on, abs( bck(x) ) * is the equivalence class number for object x. If bck(x) * is positive, then x is the representative of its equivalence * class. */ for ( i = 1; i <= num; ++i ) if ( bck[i] == NIL ) { bck[i] = ++numcl; for ( j = fwd[i]; j != NIL; j = fwd[j] ) bck[j] = -numcl; } return ( numcl ); }/* mkeccl - update equivalence classes based on character class xtions * * synopsis * char ccls[]; * int lenccl, fwd[llsiz], bck[llsiz], llsiz; * mkeccl( ccls, lenccl, fwd, bck, llsiz ); * * where ccls contains the elements of the character class, lenccl is the * number of elements in the ccl, fwd is the forward link-list of equivalent * characters, bck is the backward link-list, and llsiz size of the link-list * * Modified by Earle R. Horton, May, 1988 to allow for the possibility that * negative characters may be valid in the character set of the compiler. */mkeccl( ccls, lenccl, fwd, bck, llsiz )char ccls[];int lenccl, fwd[], bck[], llsiz; { int cclp, oldec, newec; int cclm, i, j; short *tmpccl; /* [ERH] Read chars into a short array on the stack. */ tmpccl = (short *)alloca(current_max_ccl_tbl_size * sizeof(short)); for (i=0; i < current_max_ccl_tbl_size; i++) tmpccl[i] = ccls[i] & BYTEMASK; /* note that it doesn't matter whether or not the character class is * negated. The same results will be obtained in either case. */ cclp = 0; while ( cclp < lenccl ) { cclm = tmpccl[cclp]; oldec = bck[cclm]; newec = cclm; j = cclp + 1; for ( i = fwd[cclm]; i != NIL && i <= llsiz; i = fwd[i] ) { /* look for the symbol in the character class */ for ( ; j < lenccl && tmpccl[j] <= i; ++j ) if ( tmpccl[j] == i ) { /* we found an old companion of cclm in the ccl. * link it into the new equivalence class and flag it as * having been processed */ bck[i] = newec; fwd[newec] = i; newec = i; tmpccl[j] = -i; /* set flag so we don't reprocess */ /* * [ERH] This trick will not work if negative characters are * valid. E.g. DEC multi-nationals, Macintosh option-characters. */ /* get next equivalence class member */ /* next 2 */ goto next_pt; } /* symbol isn't in character class. Put it in the old equivalence * class */ bck[i] = oldec; if ( oldec != NIL ) fwd[oldec] = i; oldec = i;next_pt: ; } if ( bck[cclm] != NIL || oldec != bck[cclm] ) { bck[cclm] = NIL; fwd[oldec] = NIL; } fwd[newec] = NIL; /* find next ccl member to process */ for ( ++cclp; tmpccl[cclp] < 0 && cclp < lenccl; ++cclp ) { /* reset "doesn't need processing" flag */ tmpccl[cclp] = -tmpccl[cclp]; } } /* [ERH] Feed shorts back into chars. */ for (i=0; i < current_max_ccl_tbl_size; i++) ccls[i] = tmpccl[i]; }/* mkechar - create equivalence class for single character * * synopsis * int tch, fwd[], bck[]; * mkechar( tch, fwd, bck ); */mkechar( tch, fwd, bck )int tch, fwd[], bck[]; { /* if until now the character has been a proper subset of * an equivalence class, break it away to create a new ec */ if ( fwd[tch] != NIL ) bck[fwd[tch]] = bck[tch]; if ( bck[tch] != NIL ) fwd[bck[tch]] = fwd[tch]; fwd[tch] = NIL; bck[tch] = NIL; } :MPW:MPW Tools:Tools with Source:Fast LEX:fastskeldef.h
/* macro definitions for fast/full-table C/FTL programs generated by flex */#include "flexskelcom.h"#define YY_END_OF_BUFFER_CHAR 0/* action number for "not an accepting state; back-track (not implemented)" */#define YY_BACK_TRACK 0/* action number for end-of-buffer was seen */#define YY_END_OF_BUFFER -3/* reinitializes everything except the current start condition. The last * input character is set to a newline so an initial beginning-of-line * rule will match */#define YY_FAST_INIT \ { \ yytext = yy_c_buf_p = &yy_ch_buf[1]; \ yyleng = 0; \ yy_hold_char = *yy_c_buf_p; \ }/* done before the next pattern has been matched action * change both of these if you change them at all! */#define YY_DO_BEFORE_SCAN \ *yy_c_buf_p = yy_hold_char#define YY_DO_BEFORE_RESTART \ yy_hold_char = *yy_c_buf_p/* done after the current pattern has been matched and before the * corresponding action */#define YY_DO_BEFORE_ACTION \ yytext = yy_b_buf_p; \ yyleng = YY_LENG; \ yy_hold_char = *yy_c_buf_p; \ *yy_c_buf_p = '\0'/* returns the length of the matched text */#define YY_LENG (yy_c_buf_p - yy_b_buf_p)#ifdef FLEX_FULL_TABLE#define YY_CS_TYPE int#else#define YY_CS_TYPE struct yy_trans_info *#endif/* find starting state */#ifdef FLEX_FULL_TABLE# define YY_FIND_START_STATE( x ) \ x = yy_start; \ if ( yy_b_buf_p[-1] == '\n' ) \ ++x#else# define YY_FIND_START_STATE( x ) \ x = yy_state_ptr[yy_start]; \ if ( yy_b_buf_p[-1] == '\n' ) \ x = yy_state_ptr[yy_start + 1]#endif# ifdef FLEX_USE_ECS# define yy_eq(x) e[x]# else# define yy_eq(x) x# endif/* get next jam state from packed table */#ifdef FLEX_FULL_TABLE# define YY_FIND_NEXT_MATCH \ { \ register int yy_state_info; \ while ( (yy_state_info = n[yy_current_state][yy_eq(*yy_c_buf_p)] ) != YY_JAM ) \ { \ yy_current_state = yy_state_info; \ YY_BACKTRACKING_ACTION \ yy_c_buf_p++; \ } \ }#else# define YY_FIND_NEXT_MATCH \ for ( yy_c = yy_eq(*yy_c_buf_p); \ (yy_trans_info = &yy_current_state[yy_c])->v == yy_c; \ yy_c = yy_eq(*++yy_c_buf_p) ) \ { \ yy_current_state += yy_trans_info->n; \ YY_BACKTRACKING_ACTION \ }#endif#ifdef FLEX_FULL_TABLE# define YY_FIND_ACTION( x ) x = l[yy_current_state]#else# define YY_FIND_ACTION( x ) x = yy_current_state[-1].n#endif#ifdef FLEX_FULL_TABLE# define YY_GET_NEXT_STATE yy_cur_state = n[yy_cur_state][*(yy_temp_char_ptr++)]#else# define YY_GET_NEXT_STATE yy_cur_state += yy_cur_state[*(yy_temp_char_ptr++)].n#endif#define EOB_ACT_RESTART_SCAN 2#define EOB_ACT_END_OF_FILE 3#define EOB_ACT_LAST_MATCH 4#ifdef FLEX_FULL_TABLE#define YY_DECLARE_YY_CS_PARAM int *yy_current_state#else#define YY_DECLARE_YY_CS_PARAM struct yy_trans_info *yy_current_state#endif :MPW:MPW Tools:Tools with Source:Fast LEX:flex.1
.TH FLEX 1 "13 May 1987".SH NAMEflex - fast lexical analyzer generator.SH SYNOPSIS.B flex[.B -dfirstvFILT -c[efmF] -Sskeleton_file] [ .I filename].SH DESCRIPTION.I flexis a rewrite of.I lexintended to right some of that tool's deficiencies: in particular,.I flexgenerates lexical analyzers much faster, and the analyzers usesmaller tables and run faster..SH OPTIONSIn addition to lex's.B -tflag, flex has the following options:.TP.B -dmakes the generated scanner run in.I debugmode. Whenever a pattern is recognized the scanner willwrite to.I stderra line of the form:.nf --accepting rule #n.fiRules are numbered sequentially with the first one being 1..TP.B -fhas the same effect as lex's -f flag (do not compress the scannertables); the mnemonic changes from.I fast compilationto (take your pick).I full tableor.I fast scanner.The actual compilation takes.I longer,since flex is I/O bound writing out the big table..IPThis option is equivalent to.B -cf(see below)..TP.B -iinstructs flex to generate a.I case-insensitivescanner. The case of letters given in the flex input patterns willbe ignored, and the rules will be matched regardless of case. Thematched text given in.I yytextwill have the preserved case (i.e., it will not be folded)..TP.B -rspecifies that the scanner uses the.B REJECTaction..TP.B -scauses the.I default rule(that unmatched scanner input is echoed to.I stdout)to be suppressed. If the scanner encounters input that does notmatch any of its rules, it aborts with an error. This option isuseful for finding holes in a scanner's rule set..TP.B -vhas the same meaning as for lex (print to.I stderra summary of statistics of the generated scanner). Many more statisticsare printed, though, and the summary spans several lines. Mostof the statistics are meaningless to the casual flex user..TP.B -Fspecifies that the.ulfastscanner table representation should be used. This representation isabout as fast as the full table representation.ul(-f),and for some sets of patterns will be considerably smaller (and forothers, larger). In general, if the pattern set contains both "keywords"and a catch-all, "identifier" rule, such as in the set:.nf "case" return ( TOK_CASE ); "switch" return ( TOK_SWITCH ); ... "default" return ( TOK_DEFAULT ); [a-z]+ return ( TOK_ID );.fithen you're better off using the full table representation. If onlythe "identifier" rule is present and you then use a hash table or some suchto detect the keywords, you're better off using.ul-F..IPThis option is equivalent to.B -cF(see below)..TP.B -Iinstructs flex to generate an.I interactivescanner. Normally, scanners generated by flex always look ahead one characterbefore deciding that a rule has been matched. At the possible cost of somescanning overhead (it's not clear that more overhead is involved), flex willgenerate a scanner which only looks ahead when needed. Such scanners arecalled.I interactivebecause if you want to write a scanner for an interactive system suchas a command shell, you will probably want the user's input to be terminatedwith a newline, and without.B -Ithe user will have to type a character in addition to the newline in orderto have the newline recognized. This leads to dreadful interactive performance..IPIf all this seems to confusing, here's the general rule: if a human willbe typing in input to your scanner, use.B -I,otherwise don't; if y care about how fast your scanners run anddon't want to make any assumptions about the input to your scanner,always use.B -I..IPNote,.B -Icannot be used in conjunction with.I fullor.I fast tables,i.e., the.B -f, -F, -cf,or.B -cFflags..TP.B -Linstructs flex to not generate.B #linedirectives (see below)..TP.B -Tmakes flex run in.I tracemode. It will generate a lot of messages to standard out concerningthe form of the input and the resultant non-deterministic and deterministicfinite automatons. This option is mostly for use in maintaining flex..TP .B -c[efmF]controls the degree of table compression..B -cedirects flex to construct.I equivalence classes,i.e., sets of characterswhich have identical lexical properties (for example, if the onlyappearance of digits in the flex input is in the character class"[0-9]" then the digits '0', '1', ..., '9' will all be putin the same equivalence class)..B -cfspecifies that the.I fullscanner tables should be generated - flex should not compress thetables by taking advantages of similar transition functions fordifferent states..B -cFspecifies that the alternate fast scanner representation (describedabove under the.B -Fflag)should be used..B -cmdirects flex to construct.I meta-equivalence classes,which are sets of equivalence classes (or characters, if equivalenceclasses are not being used) that are commonly used together.A lone.B -cspecifies that the scanner tables should be compressed but neitherequivalence classes nor meta-equivalence classes should be used..IPThe options.B -cfor.B -cFand.B -cmdo not make sense together - there is no opportunity for meta-equivalenceclasses if the table is not being compressed. Otherwise the optionsmay be freely mixed..IPThe default setting is.B -cemwhich specifies that flex should generate equivalence classesand meta-equivalence classes. This setting provides the highestdegree of table compression. You can trade offfaster-executing scanners at the cost of larger tables withthe following generally being true:.nf slowest smallest -cem -ce -cm -c -c{f,F}e -c{f,F} fastest largest.fi.TP.B -Sskeleton_fileoverrides the default skeleton file from which flex constructsits scanners. You'll never need this option unless you are doingflex maintenance or development..SH INCOMPATIBILITIES WITH LEX.I flexis fully compatible with.I lexwith the following exceptions:.IP -There is no run-time library to link with. You needn'tspecify.I -llwhen linking, and you must supply a main program. (Hacker's note: sincethe lex library contains a main() which simply calls yylex(), you actually.I canbe lazy and not supply your own main program and link with.I -ll.).IP -lex's.B %r(Ratfor scanners) and.B %t(translation table) optionsare not supported..IP -The do-nothing.ul-nflag is not supported..IP -When definitions are expanded, flex encloses them in parentheses.With lex, the following.nf NAME [A-Z][A-Z0-9]* %% foo{NAME}? printf( "Found it\\n" ); %%.fiwill not match the string "foo" because when the macrois expanded the rule is equivalent to "foo[A-Z][A-Z0-9]*?"and the precedence is such that the '?' is associated with"[A-Z0-9]*". With flex, the rule will be expanded to"foo([A-z][A-Z0-9]*)?" and so the string "foo" will match..IP -.B yymore()is not supported..IP -The undocumented lex-scanner internal variable.B yylinenois not supported..IP -If your input uses.B REJECT,you must run flex with the.B -rflag. If you leave out the flag, the scanner will abort at run-timewith a message that the scanner was compiled without the flag beingspecified..IP -The.B input()routine is not redefinable, though may be called to read charactersfollowing whatever has been matched by a rule. If.B input()encounters and end-of-file the normal.B yywrap()processing is done. A ``real'' end-of-file is returned as.I EOF..IPInput can be controlled by redefining the.B YY_INPUTmacro.YY_INPUT's calling sequence is "YY_INPUT(buf,result,max_size)". Itsaction is to place up to max_size characters in the character buffer "buf"and return in the integer variable "result" either thenumber of characters read or the constant YY_NULL (0 on Unix systems)systems) to indicate EOF. The default YY_INPUT reads from thefile-pointer "yyin" (which is by default.I stdin),so if youjust want to change the input file, you needn't redefineYY_INPUT - just point yyin at the input file..IPA sample redefinition of YY_INPUT (in the first section of the inputfile):.nf %{ #undef YY_INPUT #define YY_INPUT(buf,result,max_size) \\ result = (buf[0] = getchar()) == EOF ? YY_NULL : 1; %}.fiYou also can add in things like counting keeping track of theinput line number this way; but don't expect your scanner togo very fast..IP -.B output()is not supported.Output from the ECHO macro is done to the file-pointer"yyout" (default.I stdout)..IP -Trailing context is restricted to patterns which have eithera fixed-sized leading part or a fixed-sized trailing part.For example, "a*/b" and "a/b*" are okay, but not "a*/b*".This restriction is due to a bug in the trailing contextalgorithm given in.I Principles of Compiler Design(and.I Compilers - Principles, Techniques, and Tools)which can result in mismatches. Try the following lex program.nf %% x+/xy printf( "I found \\"%s\\"\\n", yytext );.fion the input "xxy". (If anyone knows of a fast algorithm forfinding the beginning of trailing context for an arbitrarypair of regular expressions, please let me know!)If you must have arbitrary trailing context, you can use.B yyless()to effect it..IP -flex reads only one input file, while lex's input is madeup of the concatenation of its input files..SH ENHANCEMENTS.IP -.I Exclusive start-conditionscan be declared by using.B %xinstead of.B %s.These start-conditions have the property that when they are active,.I no other rules are active.Thus a set of rules governed by the same exclusive start conditiondescribe a scanner which is independent of any of the other rules inthe flex input. This feature makes it easy to specify "mini-scanners"which scan portions of the input that are syntactically differentfrom the rest (e.g., comments)..IP -flex dynamically resizes its internal tables, so directives like "%a 3000"are not needed when specifying large scanners..IP -The scanning routine generated by flex is declared using the macro.B YY_DECL.By redefining this macro you can change the routine's name andits calling sequence. For example, you could use:.nf #undef YY_DECL #define YY_DECL float lexscan( a, b ) float a, b;.fito give it the name.I lexscan,returning a float, and taking two floats as arguments..IP -flex generates.B #linedirectives mapping lines in the output totheir origin in the input file..IP -You can put multiple actions on the same line, separated withsemi-colons. With lex, the following.nf foo handle_foo(); return 1;.fiis truncated to.nf foo handle_foo();.fiflex does not truncate the action. Actions that are not enclosed inbraces are terminated at the end of the line..IP -Actions can be begun with.B %{and terminated with.B %}.In this case, flex does not count braces to figure out where theaction ends - actions are terminated by the closing.B %}.This feature is useful when the enclosed action has extraneousbraces in it (usually in comments or inside inactive #ifdef's)that throw off the brace-count..IP -All of the scanner actions (e.g.,.B ECHO, yywrap ...)except the.B unput()and.B input()routines,are written as macros, so they can be redefined if necessarywithout requiring a separate library to link to..SH FILES.TP.I flex.skelskeleton scanner.TP.I flex.fastskelskeleton scanner for -f and -F.TP.I flexskelcom.hcommon definitions for skeleton files.TP.I flexskeldef.hdefinitions for compressed skeleton file.TP.I fastskeldef.hdefinitions for -f, -F skeleton file.SH "SEE ALSO".LPlex(1).LPM. E. Lesk and E. Schmidt,.I LEX - Lexical Analyzer Generator.SH AUTHORVern Paxson, with the help of many ideas and much inspiration fromVan Jacobson. Original version by Jef Poskanzer. Fast tablerepresentation is a partial implementation of a design done by VanJacobson. The implementation was done by Kevin Gong and Vern Paxson..LPThanks to the many flex beta-testers, especially Casey Leedom,Nick Christopher, Chris Faylor, Eric Goldman, Craig Leres, Mohamed el Lozy,Esmond Pitt, Jef Poskanzer, and Dave Tallman. Thanks to John Gilmore,Bob Mulcahy,Rich Salz, and Richard Stallman for help with various distribution headaches..LPSend comments to:.nf Vern Paxson Real Time Systems Bldg. 46A Lawrence Berkeley Laboratory 1 Cyclotron Rd. Berkeley, CA 94720 (415) 486-6411 vern@lbl-{csam,rtsg}.arpa ucbvax!lbl-csam.arpa!vern.fi.SH DIAGNOSTICS.LP.I flex scanner jammed -a scanner compiled with.B -shas encountered an input string which wasn't matched byany of its rules..LP.I flex input buffer overflowed -a scanner rule matched a string long enough to overflow thescanner's internal input buffer (as large as.B BUFSIZin "/usr/include/stdio.h"). You can edit.I flexskelcom.hand increase.B YY_BUF_SIZEand.B YY_MAX_LINEto increase this limit..LP.I REJECT used and scanner was.I not generated using -r -just like it sounds. Your scanner uses.B REJECT.You must run flex on the scanner description using the.B -rflag..LP.I old-style lex command ignored -the flex input contains a lex command (e.g., "%n 1000") whichis being ignored..SH BUGS.LPUse of unput() or input() trashes the current yytext and yyleng..LPUse of unput() to push back more text than was matched canresult in the pushed-back text matching a beginning-of-line ('^')rule even though it didn't come at the beginning of the line..LPNulls are not allowed in flex inputs or in the inputs toscanners generated by flex. Their presence generates fatalerrors..LPDo not mix trailing context with the '|' operator used tospecify that multiple rules use the same action. That is,avoid constructs like:.nf foo/bar | bletch | bugprone { ... }.fiThey can result in subtle mismatches. This is actually nota problem if there is only one ruleusing trailing context and it is the first in the list (so theabove example will actually work okay). Theproblem is due to fall-through in the action switch statement,causing non-trailing-context rules to execute thetrailing-context code of their fellow rules. This shouldbe fixed, as it's a nasty bug and not obvious. The proper fix isfor flex to spit out a FLEX_TRAILING_CONTEXT_USED #define and thenhave the backup logic in a separate table which is consulted foreach rule-match, rather than as part of the rule action. Theplace to do the tweaking is in add_accept() - any kind soul wantto be a hero?.LPThe pattern:.nf x{3}.fiis considered to be variable-length for the purposes of trailingcontext, even though it has a clear fixed length..LPDue to both buffering of input and read-ahead, you cannot intermixcalls to, for example,.B getchar()with flex rules and expect it to work. Call.B input()instead..LPThe total table entries listed by the.B -vflag excludes the number of table entries needed to determinewhat rule has been matched. The number of entries is equalto the number of DFA states if the scanner was not compiledwith.B -r,and greater than the number of states if it was..LPThe scanner run-time speeds have not been optimized as muchas they deserve. Van Jacobson's work shows that the can go quitea bit faster still. :MPW:MPW Tools:Tools with Source:Fast LEX:flex.fastskel
/* A lexical scanner generated by flex */#define FLEX_FAST_SKEL#include "fastskeldef.h"%% section 1 code and the definition of YY_TRANS_OFFSET_TYPE, if needed, go here#ifndef FLEX_FULL_TABLE /* struct for yy_transition */ struct yy_trans_info { /* v is a verify for a transition. */ short v; /* In cases where its sister v *is* a "yes, there is a transition", * n is* the offset (in records) to the next state. In most cases * where there is no transition, the value of n is irrelevant. If n * is the -1th record of a state, though, then n is the action * number for that state */ YY_TRANS_OFFSET_TYPE n; };#endif%% data tables for DFA go here/* these declarations have to come after the section 1 code or lint gets * confused about whether the variables are used */FILE *yyin = stdin, *yyout = stdout;/* these variables are all declared out here so that section 3 code can * manipulate them */static char *yy_c_buf_p; /* points to current character in buffer */static char *yy_b_buf_p; /* points to start of current scan */static int yy_init = 1; /* whether we need to initialize */static int yy_start; /* start state number *//* true when we've seen an EOF for the current input file */static int yy_eof_has_been_seen;static int yy_n_chars; /* number of characters read into yy_ch_buf *//* yy_ch_buf has to be 2 characters longer than YY_BUF_SIZE because we need * to put in 2 end-of-buffer characters (this is explained where it is * done) at the end of yy_ch_buf */#ifdef MALLOC_BUFFERSstatic char *yy_ch_buf = 0L;#elsestatic char yy_ch_buf[YY_BUF_SIZE + 2];#endif/* yy_hold_char holds the character lost when yytext is formed */static char yy_hold_char;char *yytext;static int yyleng; /* length of yytext */static YY_CS_TYPE yy_last_accepting_state;static char *yy_last_accepting_cpos;static YY_CS_TYPE yy_get_previous_state();static int yy_get_next_buffer();#define FLEX_USES_BACKTRACKING#ifdef FLEX_USES_BACKTRACKING# ifdef FLEX_FULL_TABLE# define YY_BACKTRACKING_ACTION \ if ( l[yy_current_state] ) \ { \ yy_last_accepting_state = yy_current_state; \ yy_last_accepting_cpos = yy_c_buf_p; \ }# else# define YY_BACKTRACKING_ACTION \ if ( yy_current_state[-1].n ) \ { \ yy_last_accepting_state = yy_current_state; \ yy_last_accepting_cpos = yy_c_buf_p; \ }# endif#else# define YY_BACKTRACKING_ACTION#endifYY_DECL { register YY_CS_TYPE yy_current_state; register int yy_c; register struct yy_trans_info *yy_trans_info; register int yy_act;%% user's declarations go here#ifdef MALLOC_BUFFERS if(yy_ch_buf == 0L){ yy_ch_buf = (char *)malloc(YY_BUF_SIZE + 2); if(yy_ch_buf == 0L){ fprintf( stderr, "Out of memory\n"); exit(-1); } }#endif if ( yy_init ) { yy_start = 1; /* first start state */new_file: /* this is where we enter upon encountering and end-of-file and * yywrap() indicating that we should continue processing */ /* we put in the '\n' and start reading from [1] so that an * initial match-at-newline will be true. */ yy_ch_buf[0] = '\n'; yy_n_chars = 1; /* we always need two end-of-buffer characters. The first causes * a transition to the end-of-buffer state. The second causes * a jam in that state. */ yy_ch_buf[yy_n_chars] = YY_END_OF_BUFFER_CHAR; yy_ch_buf[yy_n_chars + 1] = YY_END_OF_BUFFER_CHAR; yy_eof_has_been_seen = 0; YY_FAST_INIT; yy_init = 0; } while ( 1 ) /* loops until end-of-file is reached */ { /* support of yytext and yyleng */ YY_DO_BEFORE_SCAN; /* yy_b_buf_p points to the position in yy_ch_buf of the start of the * current run. */ yy_b_buf_p = yy_c_buf_p; YY_FIND_START_STATE( yy_current_state ); YY_FIND_NEXT_MATCH; YY_DO_BEFORE_ACTION;/* we need this label to process the very last action (right before the end of * the file) */do_action: YY_FIND_ACTION( yy_act );#ifdef FLEX_DEBUG fprintf( stderr, "--accepting rule #%d\n", yy_act );#endif switch ( yy_act ) {%% actions go here case YY_BACK_TRACK: YY_DO_BEFORE_SCAN; /* undo the effects of YY_DO_BEFORE_ACTION */ yy_c_buf_p = yy_last_accepting_cpos + 1; yy_current_state = yy_last_accepting_state; YY_DO_BEFORE_ACTION; goto do_action; case YY_NEW_FILE: break; /* begin reading from new file */ case YY_DO_DEFAULT: /* we have to eat up one character and recompute yytext and * yyleng */ YY_DO_BEFORE_SCAN; /* undo the effects of YY_DO_BEFORE_ACTION */ ++yy_c_buf_p; YY_DO_BEFORE_ACTION; YY_DEFAULT_ACTION; break; case YY_END_OF_BUFFER: YY_DO_BEFORE_SCAN; /* undo the effects of YY_DO_BEFORE_ACTION */ switch ( yy_get_next_buffer() ) { case EOB_ACT_END_OF_FILE: { if ( yywrap() ) { /* note: because we've taken care in * yy_get_next_buffer() to have set up yy_b_buf_p, * we can now set up yy_c_buf_p so that if some * total hoser (like flex itself) wants * to call the scanner after we return the * YY_NULL, it'll still work - another YY_NULL * will get returned. */ yy_c_buf_p = yy_b_buf_p; return ( YY_NULL ); } else goto new_file; } break; case EOB_ACT_RESTART_SCAN: yy_c_buf_p = yy_b_buf_p; YY_DO_BEFORE_RESTART; break; case EOB_ACT_LAST_MATCH: yy_c_buf_p = &yy_ch_buf[yy_n_chars]; yy_current_state = yy_get_previous_state(); YY_DO_BEFORE_ACTION; goto do_action; } break; default: printf( "action # %d\n", yy_act ); YY_FATAL_ERROR( "fatal flex scanner internal error" ); } } }/* yy_get_next_buffer - try to read in new buffer * * synopsis * int yy_get_next_buffer(); * * returns a code representing an action * EOB_ACT_LAST_MATCH - * EOB_ACT_RESTART_SCAN - restart the scanner * EOB_ACT_END_OF_FILE - end of file */static int yy_get_next_buffer() { if ( yy_c_buf_p != &yy_ch_buf[yy_n_chars + 1] ) { YY_FATAL_ERROR( "NULL in input" ); /*NOTREACHED*/ } else { /* try to read more data */ register char *dest = yy_ch_buf; register char *source = yy_b_buf_p - 1; /* copy prev. char, too */ register int number_to_move, i; int ret_val; /* first move last chars to start of buffer */ number_to_move = yy_c_buf_p - yy_b_buf_p; for ( i = 0; i < number_to_move; ++i ) *(dest++) = *(source++); if ( yy_eof_has_been_seen ) /* don't do the read, it's not guaranteed to return an EOF, * just force an EOF */ yy_n_chars = 0; else /* read in more data */ YY_INPUT( (&yy_ch_buf[number_to_move]), yy_n_chars, YY_BUF_SIZE - number_to_move - 1 ); if ( yy_n_chars == 0 ) { if ( number_to_move == 1 ) ret_val = EOB_ACT_END_OF_FILE; else ret_val = EOB_ACT_LAST_MATCH; yy_eof_has_been_seen = 1; } else ret_val = EOB_ACT_RESTART_SCAN; yy_n_chars += number_to_move; yy_ch_buf[yy_n_chars] = YY_END_OF_BUFFER_CHAR; yy_ch_buf[yy_n_chars + 1] = YY_END_OF_BUFFER_CHAR; /* yy_b_buf_p begins at the second character in * yy_ch_buf; the first character is the one which * preceded it before reading in the latest buffer; * it needs to be kept around in case it's a * newline, so yy_get_previous_state() will have * with '^' rules active */ yy_b_buf_p = &yy_ch_buf[1]; return ( ret_val ); } }/* yy_get_previous_state - get the state just before the eob char was reached * * synopsis * YY_CS_TYPE yy_get_previous_state(); */static YY_CS_TYPE yy_get_previous_state() { register YY_CS_TYPE yy_cur_state; register char *yy_temp_char_ptr; YY_FIND_START_STATE( yy_cur_state ); for ( yy_temp_char_ptr = yy_b_buf_p; yy_temp_char_ptr < yy_c_buf_p; ) YY_GET_NEXT_STATE; return ( yy_cur_state ); }static void unput( c )int c; { YY_DO_BEFORE_SCAN; /* undo effects of setting up yytext */ if ( yy_c_buf_p < yy_ch_buf + 2 ) { /* need to shift things up to make room */ register int number_to_move = yy_n_chars + 2; /* +2 for EOB chars */ register char *dest = &yy_ch_buf[YY_BUF_SIZE + 2]; register char *source = &yy_ch_buf[number_to_move]; while ( source > yy_ch_buf ) *--dest = *--source; yy_c_buf_p += dest - source; yy_b_buf_p += dest - source; if ( yy_c_buf_p < yy_ch_buf + 2 ) YY_FATAL_ERROR( "flex scanner push-back overflow" ); } if ( yy_c_buf_p > yy_b_buf_p && yy_c_buf_p[-1] == '\n' ) yy_c_buf_p[-2] = '\n'; *--yy_c_buf_p = c; YY_DO_BEFORE_ACTION; /* set up yytext again */ }static int input() { int c; YY_DO_BEFORE_SCAN; if ( *yy_c_buf_p == YY_END_OF_BUFFER_CHAR ) { /* need more input */ yy_b_buf_p = yy_c_buf_p; ++yy_c_buf_p; switch ( yy_get_next_buffer() ) { /* this code, unfortunately, is somewhat redundant with * that above */ case EOB_ACT_END_OF_FILE: { if ( yywrap() ) { yy_c_buf_p = yy_b_buf_p; return ( EOF ); } yy_ch_buf[0] = '\n'; yy_n_chars = 1; yy_ch_buf[yy_n_chars] = YY_END_OF_BUFFER_CHAR; yy_ch_buf[yy_n_chars + 1] = YY_END_OF_BUFFER_CHAR; yy_eof_has_been_seen = 0; YY_FAST_INIT; return ( input() ); } break; case EOB_ACT_RESTART_SCAN: yy_c_buf_p = yy_b_buf_p; break; case EOB_ACT_LAST_MATCH: YY_FATAL_ERROR( "unexpected last match in input()" ); } } c = *yy_c_buf_p++ & BYTEMASK; YY_DO_BEFORE_RESTART; return ( c ); } :MPW:MPW Tools:Tools with Source:Fast LEX:flex.skel
/* A lexical scanner generated by flex */#include "flexskeldef.h"%% section 1 code and data tables for DFA go here/* these declarations have to come after the section 1 code or lint gets * confused about whether the variables are used */FILE *yyin = stdin, *yyout = stdout;/* these variables are all declared out here so that section 3 code can * manipulate them */static int yy_start, yy_b_buf_p, yy_c_buf_p, yy_e_buf_p;static int yy_saw_eof, yy_init = 1;/* yy_ch_buf has to be 1 character longer than YY_BUF_SIZE, since when * setting up yytext we can try to put a '\0' just past the end of the * matched text */#ifdef MALLOC_BUFFERSstatic char *yy_ch_buf = 0L;static int *yy_st_buf = 0L;#elsestatic char yy_ch_buf[YY_BUF_SIZE + 1];static int yy_st_buf[YY_BUF_SIZE];#endifstatic char yy_hold_char;char *yytext;static int yyleng;YY_DECL { int yy_n_chars, yy_lp, yy_iii, yy_buf_pos, yy_act;%% user's declarations go here#ifdef MALLOC_BUFFERS if(yy_ch_buf == 0L){ yy_ch_buf = (char *)malloc(YY_BUF_SIZE + 1); yy_st_buf = (int *)malloc(YY_BUF_SIZE * sizeof(int)); if(yy_ch_buf == 0L || yy_st_buf == 0L){ fprintf( stderr, "Out of memory\n"); exit(-1); } }#endif if ( yy_init ) { YY_INIT; yy_start = 1; yy_init = 0; } goto get_next_token;do_action: for ( ; ; ) { YY_DO_BEFORE_ACTION#ifdef FLEX_DEBUG fprintf( stderr, "--accepting rule #%d\n", yy_act );#endif switch ( yy_act ) {%% actions go herecase YY_NEW_FILE:break; /* begin reading from new file */case YY_DO_DEFAULT:YY_DEFAULT_ACTION;break;case YY_END_TOK:return ( YY_END_TOK );default:YY_FATAL_ERROR( "fatal flex scanner internal error" ); }get_next_token: { register int yy_curst; register char yy_sym; YY_DO_BEFORE_SCAN /* set up to begin running DFA */ yy_curst = yy_start; if ( yy_ch_buf[yy_c_buf_p] == '\n' ) ++yy_curst; /* yy_b_buf_p points to the position in yy_ch_buf * of the start of the current run. */ yy_b_buf_p = yy_c_buf_p + 1; do /* until the machine jams */ { if ( yy_c_buf_p == yy_e_buf_p ) { /* need more input */ if ( yy_e_buf_p >= YY_BUF_LIM ) { /* not enough room to do another read */ /* see if we can make some room for more chars */ yy_n_chars = yy_e_buf_p - yy_b_buf_p; if ( yy_n_chars >= 0 ) /* shift down buffer to make room */ for ( yy_iii = 0; yy_iii <= yy_n_chars; ++yy_iii ) { yy_buf_pos = yy_b_buf_p + yy_iii; yy_ch_buf[yy_iii] = yy_ch_buf[yy_buf_pos]; yy_st_buf[yy_iii] = yy_st_buf[yy_buf_pos]; } yy_b_buf_p = 0; yy_e_buf_p = yy_n_chars; if ( yy_e_buf_p >= YY_BUF_LIM ) YY_FATAL_ERROR( "flex input buffer overflowed" ); yy_c_buf_p = yy_e_buf_p; } else if ( yy_saw_eof ) {saweof: if ( yy_b_buf_p > yy_e_buf_p ) { if ( yywrap() ) { yy_act = YY_END_TOK; goto do_action; } else { YY_INIT; yy_act = YY_NEW_FILE; goto do_action; } } else /* do a jam to eat up more input */ {#ifndef FLEX_INTERACTIVE_SCANNER /* we're going to decrement yy_c_buf_p upon doing * the jam. In this case, that's wrong, since * it points to the last non-jam character. So * we increment it now to counter the decrement. */ ++yy_c_buf_p;#endif break; } } YY_INPUT( (yy_ch_buf + yy_c_buf_p + 1), yy_n_chars, YY_MAX_LINE ); if ( yy_n_chars == YY_NULL ) { if ( yy_saw_eof ) YY_FATAL_ERROR( "flex scanner saw EOF twice - shouldn't happen" ); yy_saw_eof = 1; goto saweof; } yy_e_buf_p += yy_n_chars; } ++yy_c_buf_p;#ifdef FLEX_USE_ECS yy_sym = e[(yy_ch_buf[yy_c_buf_p] & BYTEMASK)];#else yy_sym = yy_ch_buf[yy_c_buf_p];#endif#ifdef FLEX_FULL_TABLE yy_curst = n[yy_curst][yy_sym];#else /* get next state from compressed table */ while ( c[b[yy_curst] + yy_sym] != yy_curst ) { yy_curst = d[yy_curst];#ifdef FLEX_USE_MECS /* we've arrange it so that templates are never chained * to one another. This means we can afford make a * very simple test to see if we need to convert to * yy_sym's meta-equivalence class without worrying * about erroneously looking up the meta-equivalence * class twice */ if ( yy_curst >= YY_TEMPLATE ) yy_sym = m[yy_sym];#endif } yy_curst = n[b[yy_curst] + yy_sym];#endif yy_st_buf[yy_c_buf_p] = yy_curst; }#ifdef FLEX_INTERACTIVE_SCANNER while ( b[yy_curst] != YY_JAM_BASE );#else while ( yy_curst != YY_JAM ); --yy_c_buf_p; /* put back character we jammed on */#endif if ( yy_c_buf_p >= yy_b_buf_p ) { /* we matched some text */ yy_curst = yy_st_buf[yy_c_buf_p]; yy_lp = l[yy_curst];#ifdef FLEX_REJECT_ENABLEDfind_rule: /* we branch to this label when doing a REJECT */#endif for ( ; ; ) /* until we find what rule we matched */ {#ifdef FLEX_REJECT_ENABLED if ( yy_lp && yy_lp < l[yy_curst + 1] ) { yy_act = a[yy_lp]; goto do_action; /* "continue 2" */ }#else if ( yy_lp ) { yy_act = yy_lp; goto do_action; /* "continue 2" */ }#endif if ( --yy_c_buf_p < yy_b_buf_p ) break; yy_curst = yy_st_buf[yy_c_buf_p]; yy_lp = l[yy_curst]; } } /* if we got this far, then we didn't find any accepting * states */ /* so that the default applies to the first char read */ ++yy_c_buf_p; yy_act = YY_DO_DEFAULT; } } /*NOTREACHED*/ }static void unput( c )char c; { YY_DO_BEFORE_SCAN; /* undo effects of setting up yytext */ if ( yy_c_buf_p == 0 ) { register int i; register int yy_buf_pos = YY_BUF_MAX; for ( i = yy_e_buf_p; i >= yy_c_buf_p; --i ) { yy_ch_buf[yy_buf_pos] = yy_ch_buf[i]; yy_st_buf[yy_buf_pos] = yy_st_buf[i]; --yy_buf_pos; } yy_c_buf_p = YY_BUF_MAX - yy_e_buf_p; yy_e_buf_p = YY_BUF_MAX; } if ( yy_c_buf_p <= 0 ) YY_FATAL_ERROR( "flex scanner push-back overflow" ); if ( yy_c_buf_p >= yy_b_buf_p && yy_ch_buf[yy_c_buf_p] == '\n' ) yy_ch_buf[yy_c_buf_p - 1] = '\n'; yy_ch_buf[yy_c_buf_p--] = c; YY_DO_BEFORE_ACTION; /* set up yytext again */ }static int input() { int c; YY_DO_BEFORE_SCAN if ( yy_c_buf_p == yy_e_buf_p ) { /* need more input */ int yy_n_chars; /* we can throw away the entire current buffer */ if ( yy_saw_eof ) { if ( yywrap() ) return ( EOF ); YY_INIT; } yy_b_buf_p = 0;T( yy_ch_buf, yy_n_chars, YY_MAX_LINE ); if ( yy_n_chars == YY_NULL ) { yy_saw_eof = 1; if ( yywrap() ) return ( EOF ); YY_INIT; return ( input() ); } yy_c_buf_p = -1; yy_e_buf_p = yy_n_chars - 1; } c = yy_ch_buf[++yy_c_buf_p]; YY_DO_BEFORE_ACTION; return ( c & BYTEMASK); } :MPW:MPW Tools:Tools with Source:Fast LEX:flexdef.h
/* * Definitions for flex. * * modification history * -------------------- * 02b kg, vp 30sep87 .added definitions for fast scanner; misc. cleanup * 02a vp 27jun86 .translated into C/FTL *//* * Copyright (c) 1987, the University of California * * The United States Government has rights in this work pursuant to * contract no. DE-AC03-76SF00098 between the United States Department of * Energy and the University of California. * * This program may be redistributed. Enhancements and derivative works * may be created provided the new works, if made available to the general * public, are made available for use by anyone. */#include <stdio.h>#ifdef MPW#include <string.h>#else#ifdef SV#include <string.h>#define bzero(s, n) memset((char *)(s), '\000', (unsigned)(n))#else#include <strings.h>#endif#endif/* Critical where characters are signed. */#ifndef BYTEMASK#define BYTEMASK 0xFF#endifchar *sprintf(); /* keep lint happy *//* maximum line length we'll have to deal with */#define MAXLINE BUFSIZ/* maximum size of file name */#define FILENAMESIZE 1024#define min(x,y) (x < y ? x : y)#define max(x,y) (x > y ? x : y)#define true 1#define false 0#ifndef DEFAULT_SKELETON_FILE#define DEFAULT_SKELETON_FILE "flex.skel"#endif#ifndef FAST_SKELETON_FILE#define FAST_SKELETON_FILE "flex.fastskel"#endif/* special nxt[] action number for the "at the end of the input buffer" state *//* note: -1 is already taken by YY_NEW_FILE */#define END_OF_BUFFER_ACTION -3/* action number for default action for fast scanners */#define DEFAULT_ACTION -2/* special chk[] values marking the slots taking by end-of-buffer and action * numbers */#define EOB_POSITION -1#define ACTION_POSITION -2/* number of data items per line for -f output */#define NUMDATAITEMS 10/* number of lines of data in -f output before inserting a blank line for * readability. */#define NUMDATALINES 10/* transition_struct_out() definitions */#define TRANS_STRUCT_PRINT_LENGTH 15/* returns true if an nfa state has an epsilon out-transition slot * that can be used. This definition is currently not used. */#define FREE_EPSILON(state) \ (transchar[state] == SYM_EPSILON && \ trans2[state] == NO_TRANSITION && \ finalst[state] != state)/* returns true if an nfa state has an epsilon out-transition character * and both slots are free */#define SUPER_FREE_EPSILON(state) \ (transchar[state] == SYM_EPSILON && \ trans1[state] == NO_TRANSITION) \/* maximum number of NFA states that can comprise a DFA state. It's real * big because if there's a lot of rules, the initial state will have a * huge epsilon closure. */#define INITIAL_MAX_DFA_SIZE 750#define MAX_DFA_SIZE_INCREMENT 750/* array names to be used in generated machine. They're short because * we write out one data statement (which names the array) for each element * in the array. */#define ALIST 'l' /* points to list of rules accepted for a state */#define ACCEPT 'a' /* list of rules accepted for a state */#define ECARRAY 'e' /* maps input characters to equivalence classes */#define MATCHARRAY 'm' /* maps equivalence classes to meta-equivalence classes */#define BASEARRAY 'b' /* "base" array */#define DEFARRAY 'd' /* "default" array */#define NEXTARRAY 'n' /* "next" array */#define CHECKARRAY 'c' /* "check" array *//* NIL must be 0. If not, its special meaning when making equivalence classes * (it marks the representative of a given e.c.) will be unidentifiable */#define NIL 0#define JAM -1 /* to mark a missing DFA transition */#define NO_TRANSITION NIL#define UNIQUE -1 /* marks a symbol as an e.c. representative */#define INFINITY -1 /* for x{5,} constructions *//* size of input alphabet - should be size of ASCII set */#ifdef MPW#define CSIZE 255#else#define CSIZE 127#endif#define INITIAL_MAXCCLS 100 /* max number of unique character classes */#define MAXCCLS_INCREMENT 100/* size of table holding members of character classes */#define INITIAL_MAX_CCL_TBL_SIZE 500#define MAX_CCL_TBL_SIZE_INCREMENT 250#define INITIAL_MNS 2000 /* default maximum number of nfa states */#define MNS_INCREMENT 1000 /* amount to bump above by if it's not enough */#define INITIAL_MAX_DFAS 1000 /* default maximum number of dfa states */#define MAX_DFAS_INCREMENT 1000#define JAMSTATE -32766 /* marks a reference to the state that always jams *//* enough so that if it's subtracted from an NFA state number, the result * is guaranteed to be negative */#define MARKER_DIFFERENCE 32000#define MAXIMUM_MNS 31999/* maximum number of nxt/chk pairs for non-templates */#define INITIAL_MAX_XPAIRS 2000#define MAX_XPAIRS_INCREMENT 2000/* maximum number of nxt/chk pairs needed for templates */#define INITIAL_MAX_TEMPLATE_XPAIRS 2500#define MAX_TEMPLATE_XPAIRS_INCREMENT 2500#define SYM_EPSILON 0 /* to mark transitions on the symbol epsilon */#define INITIAL_MAX_SCS 40 /* maximum number of start conditions */#define MAX_SCS_INCREMENT 40 /* amount to bump by if it's not enough */#define ONE_STACK_SIZE 500 /* stack of states with only one out-transition */#define SAME_TRANS -1 /* transition is the same as "default" entry for state *//* the following percentages are used to tune table compression: * the percentage the number of out-transitions a state must be of the * number of equivalence classes in order to be considered for table * compaction by using protos */#define PROTO_SIZE_PERCENTAGE 15/* the percentage the number of homogeneous out-transitions of a state * must be of the number of total out-transitions of the state in order * that the state's transition table is first compared with a potential * template of the most common out-transition instead of with the first * proto in the proto queue */#define CHECK_COM_PERCENTAGE 50/* the percentage the number of differences between a state's transition * table and the proto it was first compared with must be of the total * number of out-transitions of the state in order to keep the first * proto as a good match and not search any further */#define FIRST_MATCH_DIFF_PERCENTAGE 10/* the percentage the number of differences between a state's transition * table and the most similar proto must be of the state's total number * of out-transitions to use the proto as an acceptable close match */#define ACCEPTABLE_DIFF_PERCENTAGE 50/* the percentage the number of homogeneous out-transitions of a state * must be of the number of total out-transitions of the state in order * to consider making a template from the state */#define TEMPLATE_SAME_PERCENTAGE 60/* the percentage the number of differences between a state's transition * table and the most similar proto must be of the state's total number * of out-transitions to create a new proto from the state */#define NEW_PROTO_DIFF_PERCENTAGE 20/* the percentage the total number of out-transitions of a state must be * of the number of equivalence classes in order to consider trying to * fit the transition table into "holes" inside the nxt/chk table. */#define INTERIOR_FIT_PERCENTAGE 15/* size of region set aside to cache the complete transition table of * protos on the proto queue to enable quick comparisons */#define PROT_SAVE_SIZE 2000#define MSP 50 /* maximum number of saved protos (protos on the proto queue) *//* maximum number of out-transitions a state can have that we'll rummage * around through the interior of the internal fast table looking for a * spot for it */#define MAX_XTIONS_FOR_FULL_INTERIOR_FIT 4/* number that, if used to subscript an array, has a good chance of producing * an error; should be small enough to fit into a short */#define BAD_SUBSCRIPT -32767/* absolute value of largest number that can be stored in a short, with a * bit of slop thrown in for general paranoia. */#define MAX_SHORT 32766/* Declarations for global variables. *//* variables for symbol tables: * sctbl - start-condition symbol table * ndtbl - name-definition symbol table * ccltab - character class text symbol table */struct hash_entry { struct hash_entry *prev, *next; unsigned char *name; unsigned char *str_val; int int_val; } ;typedef struct hash_entry *hash_table[];#define NAME_TABLE_HASH_SIZE 101#define START_COND_HASH_SIZE 101#define CCL_HASH_SIZE 101extern struct hash_entry *ndtbl[NAME_TABLE_HASH_SIZE]; extern struct hash_entry *sctbl[START_COND_HASH_SIZE];extern struct hash_entry *ccltab[CCL_HASH_SIZE];/* variables for flags: * printstats - if true (-v), dump statistics * syntaxerror - true if a syntax error has been found * eofseen - true if we've seen an eof in the input file * ddebug - if true (-d), make a "debug" scanner * trace - if true (-T), trace processing * spprdflt - if true (-s), suppress the default rule * interactive - if true (-I), generate an interactive scanner * caseins - if true (-i), generate a case-insensitive scanner * useecs - if true (-ce flag), use equivalence classes * fulltbl - if true (-cf flag), don't compress the DFA state table * usemecs - if true (-cm flag), use meta-equivalence classes * reject - if true (-r flag), generate tables for REJECT macro * fullspd - if true (-F flag), use Jacobson method of table representation * gen_line_dirs - if true (i.e., no -L flag), generate #line directives */extern int printstats, syntaxerror, eofseen, ddebug, trace, spprdflt;extern int interactive, caseins, useecs, fulltbl, usemecs, reject;extern int fullspd, gen_line_dirs;/* variables used in the flex input routines: * datapos - characters on current output line * dataline - number of contiguous lines of data in current data * statement. Used to generate readable -f output * skelfile - fd of the skeleton file * yyin - input file * temp_action_file - temporary file to hold actions * action_file_name - name of the temporary file * infilename - name of input file * linenum - current input line number */extern int datapos, dataline, linenum;extern FILE *skelfile, *yyin, *temp_action_file;extern char *infilename;extern char *action_file_name;/* variables for stack of states having only one out-transition: * onestate - state number * onesym - transition symbol * onenext - target state * onedef - default base entry * onesp - stack pointer */#ifdef MALLOC_BUFFERSextern int *onestate,*onesym,*onenext,*onedef,onesp;#elseextern int onestate[ONE_STACK_SIZE], onesym[ONE_STACK_SIZE];extern int onenext[ONE_STACK_SIZE], onedef[ONE_STACK_SIZE], onesp;#endif/* variables for nfa machine data: * current_mns - current maximum on number of NFA states * accnum - number of the last accepting state * firstst - physically the first state of a fragment * lastst - last physical state of fragment * finalst - last logical state of fragment * transchar - transition character * trans1 - transition state * trans2 - 2nd transition state for epsilons * accptnum - accepting number * lastnfa - last nfa state number created */extern int current_mns;extern int accnum, *firstst, *lastst, *finalst, *transchar;extern int *trans1, *trans2, *accptnum, lastnfa;/* variables for protos: * numtemps - number of templates created * numprots - number of protos created * protprev - backlink to a more-recently used proto * protnext - forward link to a less-recently used proto * prottbl - base/def table entry for proto * protcomst - common state of proto * firstprot - number of the most recently used proto * lastprot - number of the least recently used proto * protsave contains the entire state array for protos */#ifdef MALLOC_BUFFERSextern int numtemps, numprots, *protprev, *protnext, *prottbl;extern int *protcomst, firstprot, lastprot,#elseextern int numtemps, numprots, protprev[MSP], protnext[MSP], prottbl[MSP];extern int protcomst[MSP], firstprot, lastprot,#endif#ifdef MALLOC_BUFFERS *protsave;#else protsave[PROT_SAVE_SIZE];#endif/* variables for managing equivalence classes: * numecs - number of equivalence classes * nextecm - forward link of Equivalence Class members * ecgroup - class number or backward link of EC members * nummecs - number of meta-equivalence classes (used to compress * templates) * tecfwd - forward link of meta-equivalence classes members * tecbck - backward link of MEC's */#ifdef MALLOC_BUFFERSextern int numecs, *nextecm, *ecgroup, nummecs;extern int *tecfwd, *tecbck;#elseextern int numecs, nextecm[CSIZE + 1], ecgroup[CSIZE + 1], nummecs;extern int tecfwd[CSIZE + 1], tecbck[CSIZE + 1];#endif/* variables for start conditions: * lastsc - last start condition created * current_max_scs - current limit on number of start conditions * scset - set of rules active in start condition * scbol - set of rules active only at the beginning of line in a s.c. * scxclu - true if start condition is exclusive * actvsc - stack of active start conditions for the current rule */extern int lastsc, current_max_scs, *scset, *scbol, *scxclu, *actvsc;/* variables for dfa machine data: * current_max_dfa_size - current maximum number of NFA states in DFA * current_max_xpairs - current maximum number of non-template xtion pairs * current_max_template_xpairs - current maximum number of template pairs * current_max_dfas - current maximum number DFA states * lastdfa - last dfa state number created * nxt - state to enter upon reading character * chk - check value to see if "nxt" applies * tnxt - internal nxt table for templates * base - offset into "nxt" for given state * def - where to go if "chk" disallows "nxt" entry * tblend - last "nxt/chk" table entry being used * firstfree - first empty entry in "nxt/chk" table * dss - nfa state set for each dfa * dfasiz - size of nfa state set for each dfa * dfaacc - accepting set for each dfa state (or accepting number, if * -r is not given) * accsiz - size of accepting set for each dfa state * dhash - dfa state hash value * todo - queue of DFAs still to be processed * todo_head - head of todo queue * todo_next - next available entry on todo queue * numas - number of DFA accepting states created; note that this * is not necessarily the same value as accnum, which is the analogous * value for the NFA * numsnpairs - number of state/nextstate transition pairs * jambase - position in base/def where the default jam table starts * jamstate - state number corresponding to "jam" state * end_of_buffer_state - end-of-buffer dfa state number */extern int current_max_dfa_size, current_max_xpairs;extern int current_max_template_xpairs, current_max_dfas;extern int lastdfa, lasttemp, *nxt, *chk, *tnxt;extern int *base, *def, tblend, firstfree, **dss, *dfasiz;extern union dfaacc_union { int *dfaacc_set; int dfaacc_state; } *dfaacc;extern int *accsiz, *dhash, *todo, todo_head, todo_next, numas;extern int numsnpairs, jambase, jamstate;extern int end_of_buffer_state;/* variables for ccl information: * lastccl - ccl index of the last created ccl * current_maxccls - current limit on the maximum number of unique ccl's * cclmap - maps a ccl index to its set pointer * ccllen - gives the length of a ccl * cclng - true for a given ccl if the ccl is negated * cclreuse - counts how many times a ccl is re-used * current_max_ccl_tbl_size - current limit on number of characters needed * to represent the unique ccl's * ccltbl - holds the characters in each ccl - indexed by cclmap */extern int lastccl, current_maxccls, *cclmap, *ccllen, *cclng, cclreuse;extern int current_max_ccl_tbl_size;extern char *ccltbl;/* variables for miscellaneous information: * starttime - real-time when we started * endtime - real-time when we ended * nmstr - last NAME scanned by the scanner * sectnum - section number currently being parsed * nummt - number of empty nx
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:Fast LEX:flexdef.h
+++++ Continued from previous card +++++
t/chk table entries * hshcol - number of hash collisions detected by snstods * dfaeql - number of times a newly created dfa was equal to an old one * numeps - number of epsilon NFA states created * eps2 - number of epsilon states which have 2 out-transitions * num_reallocs - number of times it was necessary to realloc() a group * of arrays * tmpuses - number of DFA states that chain to templates * totnst - total number of NFA states used to make DFA states * peakpairs - peak number of transition pairs we had to store internally * numuniq - number of unique transitions * numdup - number of duplicate transitions * hshsave - number of hash collisions saved by checking number of states */extern char *starttime, *endtime, nmstr[MAXLINE];extern int sectnum, nummt, hshcol, dfaeql, numeps, eps2, num_reallocs;extern int tmpuses, totnst, peakpairs, numuniq, numdup, hshsave;char *allocate_array(), *reallocate_array();#define allocate_integer_array(size) \ (int *) allocate_array( size, sizeof( int ) )#define reallocate_integer_array(array,size) \ (int *) reallocate_array( (char *) array, size, sizeof( int ) )#define allocate_integer_pointer_array(size) \ (int **) allocate_array( size, sizeof( int * ) )#define allocate_dfaacc_union(size) \ (union dfaacc_union *) \ allocate_array( size, sizeof( union dfaacc_union ) )#define reallocate_integer_pointer_array(array,size) \ (int **) reallocate_array( (char *) array, size, sizeof( int * ) )#define reallocate_dfaacc_union(array, size) \ (union dfaacc_union *) reallocate_array( (char *) array, size, sizeof( union dfaacc_union ) )#define allocate_character_array(size) allocate_array( size, sizeof( char ) )#define reallocate_character_array(array,size) \ reallocate_array( array, size, sizeof( char ) )/* used to communicate between scanner and parser. The type should really * be YYSTYPE, but we can't easily get our hands on it. */extern int yylval; :MPW:MPW Tools:Tools with Source:Fast LEX:flexit
# MPW: Convert <stdin> into a lexical scanner named link.out.flex -t | c -g -Dyylex=mainlink -w -b -c 'MPS ' -t MPST ∂ c.o ∂ "{CLibraries}"stubs.c.o ∂ "{CLibraries}"CRuntime.o ∂ "{CLibraries}"StdCLib.o ∂ "{CLibraries}"CSANELib.o ∂ "{CLibraries}"CInterface.o ∂ "{Libraries}"Interface.o :MPW:MPW Tools:Tools with Source:Fast LEX:flexskelcom.h
/* common macro definitions for C/FTL programs generated by flex *//* Critical where characters are signed. */#define BYTEMASK 0xFF/* returned upon end-of-file */#define YY_END_TOK 0/* action number for an "end-of-file was seen and yywrap indicated that we * should continue processing" */#define YY_NEW_FILE -1/* action number for "the default action should be done" */#define YY_DO_DEFAULT -2#ifndef BUFSIZ#include <stdio.h>#endif#define YY_BUF_SIZE (BUFSIZ * 2) /* size of input buffer *//* number of characters one rule can match. One less than YY_BUF_SIZE to make * sure we never access beyond the end of an array */#define YY_BUF_MAX (YY_BUF_SIZE - 1)/* we will never use more than the first YY_BUF_LIM + YY_MAX_LINE positions * of the input buffer */#ifndef YY_MAX_LINE#define YY_MAX_LINE BUFSIZ#endif#define YY_BUF_LIM (YY_BUF_MAX - YY_MAX_LINE)/* copy whatever the last rule matched to the standard output */#define ECHO fputs( yytext, yyout )/* gets input and stuffs it into "buf". number of characters read, or YY_NULL, * is returned in "result". */#define YY_INPUT(buf,result,max_size) \ if ( (result = read( fileno(yyin), buf, max_size )\ YY_FATAL_ERROR( "read() in flex scanner failed" );#define YY_NULL 0/* macro used to output a character */#define YY_OUTPUT(c) putc( c, yyout );/* report a fatal error */#define YY_FATAL_ERROR(msg) \ { \ fputs( msg, stderr ); \ putc( '\n', stderr ); \ exit( 1 ); \ }/* returns the first character of the matched text */#define YY_FIRST_CHAR yy_ch_buf[yy_b_buf_p]/* default yywrap function - always treat EOF as an EOF */#define yywrap() 1/* enter a start condition. This macro really ought to take a parameter, * but we do it the disgusting crufty way that old Unix-lex does it */#define BEGIN yy_start = 1 +/* callable from YY_INPUT to set things up so that '%' will match. Proper * usage is "YY_SET_BOL(array,pos)" */#define YY_SET_BOL(array,pos) array[pos - 1] = '\n';/* default declaration of generated scanner - a define so the user can * easily add parameters */#define YY_DECL int yylex()/* return all but the first 'n' matched characters back to the input stream */#define yyless(n) \ { \ YY_DO_BEFORE_SCAN; /* undo effects of setting up yytext */ \ yy_c_buf_p = yy_b_buf_p + n - 1; \ YY_DO_BEFORE_ACTION; /* set up yytext again */ \ }/* code executed at the end of each rule */#define YY_BREAK break; :MPW:MPW Tools:Tools with Source:Fast LEX:flexskeldef.h
/* macro definitions for compressed-table C/FTL programs generated by flex */#include "flexskelcom.h"/* reinitializes everything except the current start condition. The last * input character is set to a newline so an initial beginning-of-line * rule will match */#define YY_INIT \ { \ yyleng = yy_c_buf_p = yy_e_buf_p = 0; \ yy_hold_char = yy_ch_buf[yy_c_buf_p] = '\n'; \ yytext = &yy_ch_buf[yy_c_buf_p]; \ yy_saw_eof = 0; \ }/* returns the length of the matched text */#define YY_LENG (yy_c_buf_p - yy_b_buf_p + 1)/* done before the next pattern has been matched action */#define YY_DO_BEFORE_SCAN \ yytext[yyleng] = yy_hold_char;/* done after the current pattern has been matched and before the corresponding action */#define YY_DO_BEFORE_ACTION \ yytext = &yy_ch_buf[yy_b_buf_p]; \ yyleng = YY_LENG; \ yy_hold_char = yytext[yyleng]; \ yytext[yyleng] = '\0';/* find the next rule matched */#ifdef FLEX_REJECT_ENABLED#define REJECT \ { \ YY_DO_BEFORE_SCAN; /* undo effects of setting up yytext */ \ ++yy_lp; \ goto find_rule; \ }#else#define REJECT YY_FATAL_ERROR( "REJECT used and scanner was not generated using -r" )#endif :MPW:MPW Tools:Tools with Source:Fast LEX:main.c
/* flex - tool to generate fast lexical analyzers * * * Copyright (c) 1987, the University of California * * The United States Government has rights in this work pursuant to * contract no. DE-AC03-76SF00098 between the United States Department of * Energy and the University of California. * * This program may be redistributed. Enhancements and derivative works * may be created provided the new works, if made available to the general * public, are made available for use by anyone. * * * ver date who remarks * --- ---- ------ ------------------------------------------------------- * 04b 30sep87 kg, vp .implemented (part of) Van Jacobson's fast scanner design * 04a 27jun86 vp .translated from Ratfor into C * 01a 22aug83 vp .written. Original version by Jef Poskanzer. */#include "flexdef.h"/* these globals are all defined and commented in flexdef.h */int printstats, syntaxerror, eofseen, ddebug, trace, spprdflt;int interactive, caseins, useecs, fulltbl, usemecs, reject;int fullspd, gen_line_dirs;int datapos, dataline, linenum;FILE *skelfile = NULL;char *infilename = NULL;#ifdef MALLOC_BUFFERSint *onestate,*onesym,*onenext,*onedef,onesp;#elseint onestate[ONE_STACK_SIZE], onesym[ONE_STACK_SIZE];int onenext[ONE_STACK_SIZE], onedef[ONE_STACK_SIZE], onesp;#endifint current_mns;int accnum, *firstst, *lastst, *finalst, *transchar;int *trans1, *trans2, *accptnum, lastnfa;#ifdef MALLOC_BUFFERSint numtemps, numprots, *protprev, *protnext, *prottbl;int *protcomst, firstprot, lastprot,#elseint numtemps, numprots, protprev[MSP], protnext[MSP], prottbl[MSP];int protcomst[MSP], firstprot, lastprot,#endif#ifdef MALLOC_BUFFERS *protsave;#else protsave[PROT_SAVE_SIZE];#endif#ifdef MALLOC_BUFFERSint numecs, *nextecm, *ecgroup, nummecs;int *tecfwd, *tecbck;#elseint numecs, nextecm[CSIZE + 1], ecgroup[CSIZE + 1], nummecs;int tecfwd[CSIZE + 1], tecbck[CSIZE + 1];#endifint lastsc, current_max_scs, *scset, *scbol, *scxclu, *actvsc;int current_max_dfa_size, current_max_xpairs;int current_max_template_xpairs, current_max_dfas;int lastdfa, *nxt, *chk, *tnxt;int *base, *def, tblend, firstfree, numtemps, **dss, *dfasiz;union dfaacc_union *dfaacc;int *accsiz, *dhash, *todo, todo_head, todo_next, numas;int numsnpairs, jambase, jamstate;int lastccl, current_maxccls, *cclmap, *ccllen, *cclng, cclreuse;int current_max_ccl_tbl_size;char *ccltbl;char *starttime, *endtime, nmstr[MAXLINE];int sectnum, nummt, hshcol, dfaeql, numeps, eps2, num_reallocs;int tmpuses, totnst, peakpairs, numuniq, numdup, hshsave;FILE *temp_action_file;int end_of_buffer_state;char *action_file_name = "/tmp/flexXXXXXX";/* flex - main program * * synopsis (from the shell) * flex [-v] [file ...] */main( argc, argv )int argc;char **argv; {#ifdef MALLOC_BUFFERS#define GETBUF(a,b) a = (int *)(malloc((b)*sizeof(int))) GETBUF(onestate,ONE_STACK_SIZE); GETBUF(onesym,ONE_STACK_SIZE); GETBUF(onenext,ONE_STACK_SIZE); GETBUF(onedef,ONE_STACK_SIZE); GETBUF(protprev,MSP); GETBUF(protnext,MSP); GETBUF(prottbl,MSP); GETBUF(protcomst,MSP); GETBUF(protsave,PROT_SAVE_SIZE); GETBUF(nextecm,CSIZE + 1); GETBUF(ecgroup,CSIZE + 1); GETBUF(tecfwd,CSIZE + 1); GETBUF(tecbck,CSIZE + 1); if(onestate == NULL || onesym == NULL || onenext == NULL || onedef == NULL || protprev == NULL || protnext == NULL || prottbl == NULL || protcomst == NULL || protsave == NULL || nextecm == NULL || ecgroup == NULL || tecfwd == NULL || tecbck == NULL){ fprintf(stderr,"%s: Out of memory\n",argv[0]); exit(-1); }#endif flexinit( argc, argv ); readin(); if ( ! syntaxerror ) { /* convert the ndfa to a dfa */ ntod(); /* generate the C state transition tables from the DFA */ make_tables(); } /* note, flexend does not return. It exits with its argument as status. */ flexend( 0 ); }/* flexend - terminate flex * * synopsis * int status; * flexend( status ); * * status is exit status. * * note * This routine does not return. */flexend( status )int status; { int tblsiz; char *gettime(); if ( skelfile != NULL ) (void) fclose( skelfile ); if ( temp_action_file ) { (void) fclose( temp_action_file ); (void) unlink( action_file_name ); } if ( printstats ) { endtime = gettime(); fprintf( stderr, "flex usage statistics:\n" ); fprintf( stderr, " started at %s, finished at %s\n", starttime, endtime ); fprintf( stderr, " %d/%d NFA states\n", lastnfa, current_mns ); fprintf( stderr, " %d/%d DFA states (%d words)\n", lastdfa, current_max_dfas, totnst ); fprintf( stderr, " %d rules\n", accnum ); fprintf( stderr, " %d/%d start conditions\n", lastsc, current_max_scs ); fprintf( stderr, " %d epsilon states, %d double epsilon states\n", numeps, eps2 ); if ( lastccl == 0 ) fprintf( stderr, " no character classes\n" ); else fprintf( stderr, " %d/%d character classes needed %d/%d words of storage, %d reused\n", lastccl, current_maxccls, cclmap[lastccl] + ccllen[lastccl] - 1, current_max_ccl_tbl_size, cclreuse ); fprintf( stderr, " %d state/nextstate pairs created\n", numsnpairs ); fprintf( stderr, " %d/%d unique/duplicate transitions\n", numuniq, numdup ); if ( fulltbl ) { tblsiz = lastdfa * numecs; fprintf( stderr, " %d table entries\n", tblsiz ); } else { tblsiz = 2 * (lastdfa + numtemps) + 2 * tblend; fprintf( stderr, " %d/%d base/def entries created\n", lastdfa + numtemps, current_max_dfas ); fprintf( stderr, " %d/%d (peak %d) nxt/chk entrted\n", tblend, current_max_xpairs, peakpairs ); fprintf( stderr, " %d/%d (peak %d) template nxt/chk entries created\n", numtemps * nummecs, current_max_template_xpairs, numtemps * numecs ); fprintf( stderr, " %d empty table entries\n", nummt ); fprintf( stderr, " %d protos created\n", numprots ); fprintf( stderr, " %d templates created, %d uses\n", numtemps, tmpuses ); } if ( useecs ) { tblsiz = tblsiz + CSIZE; fprintf( stderr, " %d/%d equivalence classes created\n", numecs, CSIZE ); } if ( usemecs ) { tblsiz = tblsiz + numecs; fprintf( stderr, " %d/%d meta-equivalence classes created\n", nummecs, CSIZE ); } fprintf( stderr, " %d (%d saved) hash collisions, %d DFAs equal\n", hshcol, hshsave, dfaeql ); fprintf( stderr, " %d sets of reallocations needed\n", num_reallocs ); fprintf( stderr, " %d total table entries needed\n", tblsiz ); } exit( status ); }/* flexinit - initialize flex * * synopsis * int argc; * char **argv; * flexinit( argc, argv ); */flexinit( argc, argv )int argc;char **argv; { int i, sawcmpflag, use_stdout; char *arg, *skelname = NULL, *gettime(), clower(), *mktemp(); printstats = syntaxerror = trace = spprdflt = interactive = caseins = false; ddebug = fulltbl = reject = fullspd = false; gen_line_dirs = usemecs = useecs = true; sawcmpflag = false; use_stdout = false; /* read flags */ for ( --argc, ++argv; argc ; --argc, ++argv ) { if ( argv[0][0] != '-' || argv[0][1] == '\0' ) break; arg = argv[0]; for ( i = 1; arg[i] != '\0'; ++i ) switch ( arg[i] ) { case 'c': if ( i != 1 ) flexerror( "-c flag must be given separately" ); if ( ! sawcmpflag ) { useecs = false; usemecs = false; fulltbl = false; sawcmpflag = true; } for ( ++i; arg[i] != '\0'; ++i ) switch ( clower( arg[i] ) ) { case 'e': useecs = true; break; case 'F': fullspd = true; break; case 'f': fulltbl = true; break; case 'm': usemecs = true; break; default: lerrif( "unknown -c option %c", (int) arg[i] ); break; } goto get_next_arg; case 'd': ddebug = true; break; case 'f': useecs = usemecs = false; fulltbl = true; break; case 'I': interactive = true; break; case 'i': caseins = true; break; case 'L': gen_line_dirs = false; break; case 'r': reject = true; break; case 'F': useecs = usemecs = false; fullspd = true; break; case 'S': if ( i != 1 ) flexerror( "-S flag must be given separately" ); skelname = arg + i + 1; goto get_next_arg; case 's': spprdflt = true; break; case 't': use_stdout = true; break; case 'T': trace = true; break; case 'v': printstats = true; break; default: lerrif( "unknown flag %c", (int) arg[i] ); break; }get_next_arg: /* used by -c and -S flags in lieu of a "continue 2" control */ ; } if ( (fulltbl || fullspd) && usemecs ) flexerror( "full table and -cm don't make sense together" ); if ( (fulltbl || fullspd) && interactive ) flexerror( "full table and -I are (currently) incompatible" ); if ( (fulltbl || fullspd) && reject ) flexerror( "reject (-r) cannot be used with -f or -F" ); if ( fulltbl && fullspd ) flexerror( "full table and -F are mutually exclusive" ); if ( ! skelname ) { static char skeleton_name_storage[400]; skelname = skeleton_name_storage; if ( fullspd || fulltbl ) (void) strcpy( skelname, FAST_SKELETON_FILE ); else (void) strcpy( skelname, DEFAULT_SKELETON_FILE ); } if ( ! use_stdout ) { FILE *prev_stdout = freopen( "lex.yy.c", "w", stdout ); if ( prev_stdout == NULL ) flexerror( "could not create lex.yy.c" ); } if ( argc ) { if ( argc > 1 ) flexerror( "extraneous argument(s) given" ); yyin = fopen( infilename = argv[0], "r" ); if ( yyin == NULL ) lerrsf( "can't open %s", argv[0] ); } else yyin = stdin; lastccl = 0; lastsc = 0; /* initialize the statistics */ starttime = gettime(); if ( (skelfile = fopen( skelname, "r" )) == NULL ) lerrsf( "can't open skeleton file %s", skelname );#ifndef MPW /* Single-user system. */ (void) mktemp( action_file_name );#endif if ( (temp_action_file = fopen( action_file_name, "w" )) == NULL ) lerrsf( "can't open temporary action file %s", action_file_name ); lastdfa = lastnfa = accnum = numas = numsnpairs = tmpuses = 0; numecs = numeps = eps2 = num_reallocs = hshcol = dfaeql = totnst = 0; numuniq = numdup = hshsave = eofseen = datapos = dataline = 0; onesp = numprots = 0; linenum = sectnum = 1; firstprot = NIL; /* used in mkprot() so that the first proto goes in slot 1 * of the proto queue */ lastprot = 1; if ( useecs ) { /* set up doubly-linked equivalence classes */ ecgroup[1] = NIL; for ( i = 2; i <= CSIZE; ++i ) { ecgroup[i] = i - 1; nextecm[i - 1] = i; } nextecm[CSIZE] = NIL; } else { /* put everything in its own equivalence class */ for ( i = 1; i <= CSIZE; ++i ) { ecgroup[i] = i; nextecm[i] = BAD_SUBSCRIPT; /* to catch errors */ } } set_up_initial_allocations(); }/* readin - read in the rules section of the input file(s) * * synopsis * readin(); */readin() { fputs( "#define YY_DEFAULT_ACTION ", stdout ); if ( spprdflt ) fputs( "YY_FATAL_ERROR( \"flex scanner jammed\" )", stdout ); else fputs( "ECHO", stdout ); fputs( ";\n", stdout ); if ( ddebug ) puts( "#define FLEX_DEBUG" ); if ( useecs ) puts( "#define FLEX_USE_ECS" ); if ( usemecs ) puts( "#define FLEX_USE_MECS" ); if ( interactive ) puts( "#define FLEX_INTERACTIVE_SCANNER" ); if ( reject ) puts( "#define FLEX_REJECT_ENABLED" ); if ( fulltbl ) puts( "#define FLEX_FULL_TABLE" ); skelout(); line_directive_out( stdout ); if ( yyparse() )#ifdef MPW /* See tool interface guidelines in MPW manual. */ { char *panicmsg; char *alloca(); panicmsg = alloca(128); sprintf(panicmsg,"File %s ; %%d # Fatal parse error."); lerrif(panicmsg,linenum); }#else lerrif( "fatal parse error at line %d", linenum );#endif if ( useecs ) { numecs = cre8ecs( nextecm, ecgroup, CSIZE ); ccl2ecl(); } else numecs = CSIZE; }/* set_up_initial_allocations - allocate memory for internal tables */set_up_initial_allocations() { current_mns = INITIAL_MNS; firstst = allocate_integer_array( current_mns ); lastst = allocate_integer_array( current_mns ); finalst = allocate_integer_array( current_mns ); transchar = allocate_integer_array( current_mns ); trans1 = allocate_integer_array( current_mns ); trans2 = allocate_integer_array( current_mns ); accptnum = allocate_integer_array( current_mns ); current_max_scs = INITIAL_MAX_SCS; scset = allocate_integer_array( current_max_scs ); scbol = allocate_integer_array( current_max_scs ); scxclu = allocate_integer_array( current_max_scs ); actvsc = allocate_integer_array( current_max_scs ); current_maxccls = INITIAL_MAXCCLS; cclmap = allocate_integer_array( current_maxccls ); ccllen = allocate_integer_array( current_maxccls ); cclng = allocate_integer_array( current_maxccls ); current_max_ccl_tbl_size = INITIAL_MAX_CCL_TBL_SIZE; ccltbl = allocate_character_array( current_max_ccl_tbl_size ); current_max_dfa_size = INITIAL_MAX_DFA_SIZE; current_max_xpairs = INITIAL_MAX_XPAIRS; nxt = allocate_integer_array( current_max_xpairs ); chk = allocate_integer_array( current_max_xpairs ); current_max_template_xpairs = INITIAL_MAX_TEMPLATE_XPAIRS; tnxt = allocate_integer_array( current_max_template_xpairs ); current_max_dfas = INITIAL_MAX_DFAS; base = allocate_integer_array( current_max_dfas ); def = allocate_integer_array( current_max_dfas ); dfasiz = allocate_integer_array( current_max_dfas ); accsiz = allocate_integer_array( current_max_dfas ); dhash = allocate_integer_array( current_max_dfas ); todo = allocate_integer_array( current_max_dfas ); dss = allocate_integer_pointer_array( current_max_dfas ); dfaacc = allocate_dfaacc_union( current_max_dfas ); } :MPW:MPW Tools:Tools with Source:Fast LEX:makefile
# make file for "flex" tool# MPW make version by Earle Horton, May 1988# the first time around use "make first_flex"INCLUDES = "{cincludes}"BINDIR = "{MPW}"Tools:LIBDIR = "{clibraries}"SKELETON_FILE_NAME = getenv(∂"SKELETON_FILE∂")F_SKELETON_FILE_NAME = getenv(∂"F_SKELETON_FILE∂")SKELFLAGS = -DDEFAULT_SKELETON_FILE={SKELETON_FILE_NAME} ∂ -DFAST_SKELETON_FILE={F_SKELETON_FILE_NAME}CFLAGS = -g -DMPW -DMALLOC_BUFFERSLDFLAGS = -d -b -c 'MPS ' -t MPST ∂ "{CLibraries}"stubs.c.o ∂ "{CLibraries}"CRuntime.o ∂ "{CLibraries}"StdCLib.o ∂ "{CLibraries}"CSANELib.o ∂ "{CLibraries}"CInterface.o ∂ "{Libraries}"Interface.o .c.o ƒ .c C {default}.c {CFLAGS} -o {default}.c.oFLEX_FLAGS = -istFLEX = flexFLEXOBJS = ∂ alloca.a.o ∂ bzero.c.o ∂ ccl.c.o ∂ dfa.c.o ∂ ecs.c.o ∂ main.c.o ∂ misc.c.o ∂ nfa.c.o ∂ parse.c.o ∂ scan.c.o ∂ sym.c.o ∂ tblcmp.c.o ∂ yylex.c.oFLEX_C_SOURCES = ∂ bzero.c ∂ ccl.c ∂ dfa.c ∂ ecs.c ∂ main.c ∂ misc.c ∂ nfa.c ∂ parse.c ∂ scan.c ∂ sym.c ∂ tblcmp.c ∂ yylex.cflex ƒ {FLEXOBJS} Link -o flex {FLEXOBJS} {LDFLAGS}first_flex ƒ duplicate scan.c.dist scan.c make {MFLAGS} flex parse.c ƒ parse.y yacc -d parse.y move -y y.tab.c parse.c move -y y.tab.h parse.hparse.h ƒ parse.c# comment-out the next two lines after a successful "make test" and# comment-in the following two lines.scan.c ƒ scan.l {FLEX} {FLEX_FLAGS} scan.l >scan.cscan.c.o ƒ scan.c parse.hmain.c.o ƒ main.c c {CFLAGS} {SKELFLAGS} main.c# Anybody have lint?flex.lint ƒ {FLEX_C_SOURCES} echo "Expect a ∂"may be used before set∂" and 2 ∂"unused∂"'s lint {FLEX_C_SOURCES} > flex.lintclean ƒ delete -i flex ≈.o parse.c parse.h scan.ctest ƒ echo "This step destroys junk.c." {FLEX} {FLEX_FLAGS} scan.l > junk.c compare scan.c junk.c delete junk.cinstall ƒ {FLEX} duplicate -y {FLEX} {BINDIR} duplicate -y flexskelcom.h {INCLUDES} duplicate -y flexskeldef.h {INCLUDES} duplicate -y fastskeldef.h {INCLUDES} duplicate -y flex.skel {LIBDIR} duplicate -y flex.fastskel {LIBDIR} :MPW:MPW Tools:Tools with Source:Fast LEX:makefile.MPW
# make file for "flex" tool# MPW make version by Earle Horton, May 1988# the first time around use "make first_flex"INCLUDES = "{cincludes}"BINDIR = "{MPW}"Tools:LIBDIR = "{clibraries}"SKELETON_FILE_NAME = getenv(∂"SKELETON_FILE∂")F_SKELETON_FILE_NAME = getenv(∂"F_SKELETON_FILE∂")SKELFLAGS = -DDEFAULT_SKELETON_FILE={SKELETON_FILE_NAME} ∂ -DFAST_SKELETON_FILE={F_SKELETON_FILE_NAME}CFLAGS = -g -DMPW -DMALLOC_BUFFERSLDFLAGS = -d -b -c 'MPS ' -t MPST ∂ "{CLibraries}"stubs.c.o ∂ "{CLibraries}"CRuntime.o ∂ "{CLibraries}"StdCLib.o ∂ "{CLibraries}"CSANELib.o ∂ "{CLibraries}"CInterface.o ∂ "{Libraries}"Interface.o .c.o ƒ .c C {default}.c {CFLAGS} -o {default}.c.oFLEX_FLAGS = -istFLEX = flexFLEXOBJS = ∂ alloca.a.o ∂ bzero.c.o ∂ ccl.c.o ∂ dfa.c.o ∂ ecs.c.o ∂ main.c.o ∂ misc.c.o ∂ nfa.c.o ∂ parse.c.o ∂ scan.c.o ∂ sym.c.o ∂ tblcmp.c.o ∂ yylex.c.oFLEX_C_SOURCES = ∂ bzero.c ∂ ccl.c ∂ dfa.c ∂ ecs.c ∂ main.c ∂ misc.c ∂ nfa.c ∂ parse.c ∂ scan.c ∂ sym.c ∂ tblcmp.c ∂ yylex.cflex ƒ {FLEXOBJS} Link -o flex {FLEXOBJS} {LDFLAGS}first_flex ƒ duplicate scan.c.dist scan.c make {MFLAGS} flex parse.c ƒ parse.y yacc -d parse.y move -y y.tab.c parse.c move -y y.tab.h parse.hparse.h ƒ parse.c# comment-out the next two lines after a successful "make test" and# comment-in the following two lines.scan.c ƒ scan.l {FLEX} {FLEX_FLAGS} scan.l >scan.cscan.c.o ƒ scan.c parse.hmain.c.o ƒ main.c c {CFLAGS} {SKELFLAGS} main.c# Anybody have lint?flex.lint ƒ {FLEX_C_SOURCES} echo "Expect a ∂"may be used before set∂" and 2 ∂"unused∂"'s lint {FLEX_C_SOURCES} > flex.lintclean ƒ delete -i flex ≈.o parse.c parse.h scan.ctest ƒ echo "This step destroys junk.c." {FLEX} {FLEX_FLAGS} scan.l > junk.c compare scan.c junk.c delete junk.cinstall ƒ {FLEX} duplicate -y {FLEX} {BINDIR} duplicate -y flexskelcom.h {INCLUDES} duplicate -y flexskeldef.h {INCLUDES} duplicate -y fastskeldef.h {INCLUDES} duplicate -y flex.skel {LIBDIR} duplicate -y flex.fastskel {LIBDIR} :MPW:MPW Tools:Tools with Source:Fast LEX:makefile.UNIX
# make file for "flex" tool# the first time around use "make first_flex"SKELETON_FILE = \"/usr/local/lib/flex.skel\"F_SKELETON_FILE = \"/usr/local/lib/flex.fastskel\"SKELFLAGS = -DDEFAULT_SKELETON_FILE=$(SKELETON_FILE) \ -DFAST_SKELETON_FILE=$(F_SKELETON_FILE)CFLAGS = -OLDFLAGS =FLEX_FLAGS = -istFLEX = flexFLEXOBJS = \ ccl.o \ dfa.o \ ecs.o \ main.o \ misc.o \ nfa.o \ parse.o \ scan.o \ sym.o \ tblcmp.o \ yylex.oFLEX_C_SOURCES = \ ccl.c \ dfa.c \ ecs.c \ main.c \ misc.c \ nfa.c \ parse.c \ scan.c \ sym.c \ tblcmp.c \ yylex.cflex : $(FLEXOBJS) cc $(CFLAGS) -o flex $(LDFLAGS) $(FLEXOBJS)first_flex: cp scan.c.dist scan.c make $(MFLAGS) flexparse.h parse.c : parse.y yacc -d parse.y @mv y.tab.c parse.c @mv y.tab.h parse.h# comment-out the next two lines after a successful "make test" and# comment-in the following two lines.scan.c : scan.l $(FLEX) $(FLEX_FLAGS) scan.l >scan.cscan.o : scan.c parse.hmain.o : main.c cc $(CFLAGS) -c $(SKELFLAGS) main.cflex.lint : $(FLEX_C_SOURCES) @echo "Expect a \"may be used before set\" and 2 \"unused\"'s lint $(FLEX_C_SOURCES) > flex.lintclean : rm -f core errs flex *.o parse.c *.lint parse.htest : $(FLEX) $(FLEX_FLAGS) scan.l | diff scan.c - :MPW:MPW Tools:Tools with Source:Fast LEX:manifest
Name --------alloca.a bzero.c ccl.cChangesdfa.cecs.cfastskeldef.hflex.1flex.fastskelflex.man.pageflex.skelflexdef.hflexit flexskelcom.h flexskeldef.hmain.cmakefile.MPWmakefile.UNIXmanifestmisc.cnfa.cparse.yREADMEREADME_for_Macintoshscan.c.distscan.lsym.ctblcmp.cTimingsyylex.c :MPW:MPW Tools:Tools with Source:Fast LEX:misc.c
/* misc - miscellaneous flex routines *//* * Copyright (c) 1987, the University of California * * The United States Government has rights in this work pursuant to * contract no. DE-AC03-76SF00098 between the United States Department of * Energy and the University of California. * * This program may be redistributed. Enhancements and derivative works * may be created provided the new works, if made available to the general * public, are made available for use by anyone. */#include <ctype.h>#include "flexdef.h"char *malloc(), *realloc();/* action_out - write the actions from the temporary file to lex.yy.c * * synopsis * action_out(); * * Copies the action file up to %% (or end-of-file) to lex.yy.c */action_out() { char buf[MAXLINE]; while ( fgets( buf, MAXLINE, temp_action_file ) != NULL ) if ( buf[0] == '%' && buf[1] == '%' ) break; else fputs( buf, stdout ); }/* allocate_array - allocate memory for an integer array of the given size */char *allocate_array( size, element_size )int size, element_size; { register char *mem = malloc( (unsigned) (element_size * size) ); if ( mem == NULL ) flexfatal( "memory allocation failed in allocate_array()" ); return ( mem ); }/* bubble - bubble sort an integer array in increasing order * * synopsis * int v[n], n; * bubble( v, n ); * * description * sorts the first n elements of array v and replaces them in * increasing order. * * passed * v - the array to be sorted * n - the number of elements of 'v' to be sorted */bubble( v, n )int v[], n; { register int i, j, k; for ( i = n; i > 1; --i ) for ( j = 1; j < i; ++j ) if ( v[j] > v[j + 1] ) /* compare */ { k = v[j]; /* exchange */ v[j] = v[j + 1]; v[j + 1] = k; } }/* clower - replace upper-case letter to lower-case * * synopsis: * char clower(), c; * c = clower( c ); */char clower( c )register char c; { return ( isupper(c) ? tolower(c) : c ); }/* copy_string - returns a dynamically allocated copy of a string * * synopsis * char *str, *copy, *copy_string(); * copy = copy_string( str ); */char *copy_string( str )register char *str; { register char *c; char *copy; /* find length */ for ( c = str; *c; ++c ) ; copy = malloc( (unsigned) ((c - str + 1) * sizeof( char )) ); if ( copy == NULL ) flexfatal( "dynamic memory failure in copy_string()" ); for ( c = copy; (*c++ = *str++); ) ; return ( copy ); }/* cshell - shell sort a character array in increasing order * * synopsis * * char v[n]; * int n; * cshell( v, n ); * * description * does a shell sort of the first n elements of array v. * * passed * v - array to be sorted * n - number of elements of v to be sorted */cshell( v, n )char v[];int n; { int gap, i, j, jg; char k; for ( gap = n / 2; gap > 0; gap = gap / 2 ) for ( i = gap; i < n; ++i ) for ( j = i - gap; j >= 0; j = j - gap ) { jg = j + gap; if ( v[j] <= v[jg] ) break; k = v[j]; v[j] = v[jg]; v[jg] = k; } }/* dataend - finish up a block of data declarations * * synopsis * dataend(); */dataend() { if ( datapos > 0 ) dataflush(); /* add terminator for initialization */ puts( " } ;\n" ); dataline = 0; }/* dataflush - flush generated data statements * * synopsis * dataflush(); */dataflush() { putchar( '\n' ); if ( ++dataline >= NUMDATALINES ) { /* put out a blank line so that the table is grouped into * large blocks that enable the user to find elements easily */ putchar( '\n' ); dataline = 0; } /* reset the number of characters written on the current line */ datapos = 0; }/* gettime - return current time * * synopsis * char *gettime(), *time_str; * time_str = gettime(); */#ifdef MPWpascal void IUTIMESTRING(dateTime, wantSeconds, result) long dateTime; short wantSeconds; char *result; extern;char *p2cstr();char *gettime() { char *copy_string(); long curtime; char strbuf[256]; GetDateTime(&curtime); IUTIMESTRING(curtime,true,strbuf); p2cstr(strbuf); return (copy_string(strbuf));}#else/* include sys/types.h to use time_t and make lint happy */#include <sys/types.h>char *gettime() { time_t t, time(); char *result, *ctime(), *copy_string(); t = time( (long *) 0 ); result = copy_string( ctime( &t ) ); /* get rid of trailing newline */ result[24] = '\0'; return ( result ); }#endif/* lerrif - report an error message formatted with one integer argument * * synopsis * char msg[]; * int arg; * lerrif( msg, arg ); */lerrif( msg, arg )char msg[];int arg; { char errmsg[MAXLINE]; (void) sprintf( errmsg, msg, arg ); flexerror( errmsg ); }/* lerrsf - report an error message formatted with one string argument * * synopsis * char msg[], arg[]; * lerrsf( msg, arg ); */lerrsf( msg, arg )char msg[], arg[]; { char errmsg[MAXLINE]; (void) sprintf( errmsg, msg, arg ); flexerror( errmsg ); }/* flexerror - report an error message and terminate * * synopsis * char msg[]; * flexerror( msg ); */flexerror( msg )char msg[]; { fprintf( stderr, "flex: %s\n", msg ); flexend( 1 ); }/* flexfatal - report a fatal error message and terminate * * synopsis * char msg[]; * flexfatal( msg ); */flexfatal( msg )char msg[]; { fprintf( stderr, "flex: fatal internal error %s\n", msg ); flexend( 1 ); }/* line_directive_out - spit out a "# line" statement */line_directive_out( output_file_name )FILE *output_file_name; { if ( infilename && gen_line_dirs ) fprintf( output_file_name, "# line %d \"%s\"\n", linenum, infilename ); }/* mk2data - generate a data statement for a two-dimensional array * * synopsis * int value; * mk2data( value ); * * generates a data statement initializing the current 2-D array to "value" */mk2data( value )int value; { if ( datapos >= NUMDATAITEMS ) { putchar( ',' ); dataflush(); } if ( datapos == 0 ) /* indent */ fputs( " ", stdout ); else putchar( ',' ); ++datapos; printf( "%5d", value ); }/* mkdata - generate a data statement * * synopsis * int value; * mkdata( value ); * * generates a data statement initializing the current array element to * "value" */mkdata( value )int value; { if ( datapos >= NUMDATAITEMS ) { putchar( ',' ); dataflush(); } if ( datapos == 0 ) /* indent */ fputs( " ", stdout ); else putchar( ',' ); ++datapos; printf( "%5d", value ); }/* myctoi - return the integer represented by a string of digits * * synopsis * char array[]; * int val, myctoi(); * val = myctoi( array ); * */int myctoi( array )char array[]; { int val = 0; (void) sscanf( array, "%d", &val ); return ( val ); }/* myesc - return character corresponding to escape sequence * * synopsis * char array[], c, myesc(); * c = myesc( array ); * */char myesc( array )char array[]; { switch ( array[1] ) { case 'n': return ( '\n' ); case 't': return ( '\t' ); case 'f': return ( '\f' ); case 'r': return ( '\r' ); case 'b': return ( '\b' ); case '0': if ( isdigit(array[2]) ) { /* \0<octal> */ char c, esc_char; register int sptr = 2; while ( isdigit(array[sptr]) ) /* don't increment inside loop control because the * macro will expand it to two increments! (Not a * problem with the C version of the macro) */ ++sptr; c = array[sptr]; array[sptr] = '\0'; esc_char = otoi( array + 2 ); array[sptr] = c; if ( esc_char == '\0' ) { synerr( "escape sequence for null not allowed" ); return ( 1 ); } return ( esc_char ); } else { synerr( "escape sequence for null not allowed" ); return ( 1 ); }#ifdef NOTDEF case '^': { register char next_char = array[2]; if ( next_char == '?' ) return ( 0x7f ); else if ( next_char >= 'A' && next_char <= 'Z' ) return ( next_char - 'A' + 1 ); else if ( next_char >= 'a' && next_char <= 'z' ) return ( next_char - 'z' + 1 ); synerr( "illegal \\^ escape sequence" ); return ( 1 ); }#endif } return ( array[1] ); }/* otoi - convert an octal digit string to an integer value * * synopsis: * int val, otoi(); * char str[]; * val = otoi( str ); */int otoi( str )char str[]; {#ifdef FTLSOURCE fortran int gctoi() int dummy = 1; return ( gctoi( str, dummy, 8 ) );#else int result; (void) sscanf( str, "%o", &result ); return ( result );#endif }/* reallocate_array - increase the size of a dynamic array */char *reallocate_array( array, size, element_size )char *array;int size, element_size; { register char *new_array = realloc( array, (unsigned) (size * element_size )); if ( new_array == NULL ) flexfatal( "attempt to increase array size failed" ); return ( new_array ); }/* skelout - write out one section of the skeleton file * * synopsis * skelout(); * * DESCRIPTION * Copies from skelfile to stdout until a line beginning with "%%" or * EOF is found. */skelout() { char buf[MAXLINE]; while ( fgets( buf, MAXLINE, skelfile ) != NULL ) if ( buf[0] == '%' && buf[1] == '%' ) break; else fputs( buf, stdout ); }/* transition_struct_out - output a yy_trans_info structure * * synopsis * int element_v, element_n; * transition_struct_out( element_v, element_n ); * * outputs the yy_trans_info structure with the two elements, element_v and * element_n. Formats the output with spaces and carriage returns. */transition_struct_out( element_v, element_n )int element_v, element_n; { printf( "%7d, %5d,", element_v, element_n ); datapos += TRANS_STRUCT_PRINT_LENGTH; if ( datapos >= 75 ) { printf( "\n" ); if ( ++dataline % 10 == 0 ) printf( "\n" ); datapos = 0; } } :MPW:MPW Tools:Tools with Source:Fast LEX:nfa.c
/* nfa - NFA construction routines *//* * Copyright (c) 1987, the University of California * * The United States Government has rights in this work pursuant to * contract no. DE-AC03-76SF00098 between the United States Department of * Energy and the University of California. * * This program may be redistributed. Enhancements and derivative works * may be created provided the new works, if made available to the general * public, are made available for use by anyone. */#include "flexdef.h"/* add_accept - add an accepting state to a machine * * synopsis * * add_accept( mach, headcnt, trailcnt ); * * the global ACCNUM is incremented and the new value becomes mach's * accepting number. if headcnt or trailcnt is non-zero then the machine * recognizes a pattern with trailing context. headcnt is the number of * characters in the matched part of the pattern, or zero if the matched * part has variable length. trailcnt is the number of trailing context * characters in the pattern, or zero if the trailing context has variable * length. */add_accept( mach, headcnt, trailcnt )int mach, headcnt, trailcnt; { int astate; fprintf( temp_action_file, "case %d:\n", ++accnum ); if ( headcnt > 0 || trailcnt > 0 ) { /* do trailing context magic to not match the trailing characters */ fprintf( temp_action_file, "YY_DO_BEFORE_SCAN; /* undo effects of setting up yytext */\n" ); if ( headcnt > 0 ) { int head_offset = headcnt - 1; if ( fullspd || fulltbl ) /* with the fast skeleton, yy_c_buf_p points to the *next* * character to scan, rather than the one that was last * scanned */ ++head_offset; if ( head_offset > 0 ) fprintf( temp_action_file, "yy_c_buf_p = yy_b_buf_p + %d;\n", head_offset ); else fprintf( temp_action_file, "yy_c_buf_p = yy_b_buf_p;\n" ); } else fprintf( temp_action_file, "yy_c_buf_p -= %d;\n", trailcnt ); fprintf( temp_action_file, "YY_DO_BEFORE_ACTION; /* set up yytext again */\n" ); } line_directive_out( temp_action_file ); /* hang the accepting number off an epsilon state. if it is associated * with a state that has a non-epsilon out-transition, then the state * will accept BEFORE it makes that transition, i.e., one character * too soon */ if ( transchar[finalst[mach]] == SYM_EPSILON ) accptnum[finalst[mach]] = accnum; else { astate = mkstate( SYM_EPSILON ); accptnum[astate] = accnum; mach = link_machines( mach, astate ); } }/* copysingl - make a given number of copies of a singleton machine * * synopsis * * newsng = copysingl( singl, num ); * * newsng - a new singleton composed of num copies of singl * singl - a singleton machine * num - the number of copies of singl to be present in newsng */int copysingl( singl, num )int singl, num; { int copy, i; copy = mkstate( SYM_EPSILON ); for ( i = 1; i <= num; ++i ) copy = link_machines( copy, dupmachine( singl ) ); return ( copy ); }/* dumpnfa - debugging routine to write out an nfa * * synopsis * int state1; * dumpnfa( state1 ); */dumpnfa( state1 )int state1; { int sym, tsp1, tsp2, anum, ns; fprintf( stderr, "\n\n********** beginning dump of nfa with start state %d\n", state1 ); /* we probably should loop starting at firstst[state1] and going to * lastst[state1], but they're not maintained properly when we "or" * all of the rules together. So we use our knowledge that the machine * starts at state 1 and ends at lastnfa. */ /* for ( ns = firstst[state1]; ns <= lastst[state1]; ++ns ) */ for ( ns = 1; ns <= lastnfa; ++ns ) { fprintf( stderr, "state # %4d\t", ns ); sym = transchar[ns]; tsp1 = trans1[ns]; tsp2 = trans2[ns]; anum = accptnum[ns]; fprintf( stderr, "%3d: %4d, %4d", sym, tsp1, tsp2 ); if ( anum != NIL ) fprintf( stderr, " [%d]", anum ); fprintf( stderr, "\n" ); } fprintf( stderr, "********** end of dump\n" ); }/* dupmachine - make a duplicate of a given machine * * synopsis * * copy = dupmachine( mach ); * * copy - holds duplicate of mach * mach - machine to be duplicated * * note that the copy of mach is NOT an exact duplicate; rather, all thnsition states values are adjusted so that the copy is self-contained, * as the original should have been. * * also note that the original MUST be contiguous, with its low and high * states accessible by the arrays firstst and lastst */int dupmachine( mach )int mach; { int i, state, init, last = lastst[mach], state_offset; for ( i = firstst[mach]; i <= last; ++i ) { state = mkstate( transchar[i] ); if ( trans1[i] != NO_TRANSITION ) { mkxtion( finalst[state], trans1[i] + state - i ); if ( transchar[i] == SYM_EPSILON && trans2[i] != NO_TRANSITION ) mkxtion( finalst[state], trans2[i] + state - i ); } accptnum[state] = accptnum[i]; } state_offset = state - i + 1; init = mach + state_offset; firstst[init] = firstst[mach] + state_offset; finalst[init] = finalst[mach] + state_offset; lastst[init] = lastst[mach] + state_offset; return ( init ); }/* link_machines - connect two machines together * * synopsis * * new = link_machines( first, last ); * * new - a machine constructed by connecting first to last * first - the machine whose successor is to be last * last - the machine whose predecessor is to be first * * note: this routine concatenates the machine first with the machine * last to produce a machine new which will pattern-match first first * and then last, and will fail if either of the sub-patterns fails. * FIRST is set to new by the operation. last is unmolested. */int link_machines( first, last )int first, last; { if ( first == NIL ) return ( last ); else if ( last == NIL ) return ( first ); else { mkxtion( finalst[first], last ); finalst[first] = finalst[last]; lastst[first] = max( lastst[first], lastst[last] ); firstst[first] = min( firstst[first], firstst[last] ); return ( first ); } }/* mkbranch - make a machine that branches to two machines * * synopsis * * branch = mkbranch( first, second ); * * branch - a machine which matches either first's pattern or second's * first, second - machines whose patterns are to be or'ed (the | operator) * * note that first and second are NEITHER destroyed by the operation. Also, * the resulting machine CANNOT be used with any other "mk" operation except * more mkbranch's. Compare with mkor() */int mkbranch( first, second )int first, second; { int eps; if ( first == NO_TRANSITION ) return ( second ); else if ( second == NO_TRANSITION ) return ( first ); eps = mkstate( SYM_EPSILON ); mkxtion( eps, first ); mkxtion( eps, second ); return ( eps ); }/* mkclos - convert a machine into a closure * * synopsis * new = mkclos( state ); * * new - a new state which matches the closure of "state" */int mkclos( state )int state; { return ( mkopt( mkposcl( state ) ) ); }/* mkopt - make a machine optional * * synopsis * * new = mkopt( mach ); * * new - a machine which optionally matches whatever mach matched * mach - the machine to make optional * * notes: * 1. mach must be the last machine created * 2. mach is destroyed by the call */int mkopt( mach )int mach; { int eps; if ( ! SUPER_FREE_EPSILON(finalst[mach]) ) { eps = mkstate( SYM_EPSILON ); mach = link_machines( mach, eps ); } /* can't skimp on the following if FREE_EPSILON(mach) is true because * some state interior to "mach" might point back to the beginning * for a closure */ eps = mkstate( SYM_EPSILON ); mach = link_machines( eps, mach ); mkxtion( mach, finalst[mach] ); return ( mach ); }/* mkor - make a machine that matches either one of two machines * * synopsis * * new = mkor( first, second ); * * new - a machine which matches either first's pattern or second's * first, second - machines whose patterns are to be or'ed (the | operator) * * note that first and second are both destroyed by the operation * the code is rather convoluted because an attempt is made to minimize * the number of epsilon states needed */int mkor( first, second )int first, second; { int eps, orend; if ( first == NIL ) return ( second ); else if ( second == NIL ) return ( first ); else { /* see comment in mkopt() about why we can't use the first state * of "first" or "second" if they satisfy "FREE_EPSILON" */ eps = mkstate( SYM_EPSILON ); first = link_machines( eps, first ); mkxtion( first, second ); if ( SUPER_FREE_EPSILON(finalst[first]) && accptnum[finalst[first]] == NIL ) { orend = finalst[first]; mkxtion( finalst[second], orend ); } else if ( SUPER_FREE_EPSILON(finalst[second]) && accptnum[finalst[second]] == NIL ) { orend = finalst[second]; mkxtion( finalst[first], orend ); } else { eps = mkstate( SYM_EPSILON ); first = link_machines( first, eps ); orend = finalst[first]; mkxtion( finalst[second], orend ); } } finalst[first] = orend; return ( first ); }/* mkposcl - convert a machine into a positive closure * * synopsis * new = mkposcl( state ); * * new - a machine matching the positive closure of "state" */int mkposcl( state )int state; { int eps; if ( SUPER_FREE_EPSILON(finalst[state]) ) { mkxtion( finalst[state], state ); return ( state ); } else { eps = mkstate( SYM_EPSILON ); mkxtion( eps, state ); return ( link_machines( state, eps ) ); } }/* mkrep - make a replicated machine * * synopsis * new = mkrep( mach, lb, ub ); * * new - a machine that matches whatever "mach" matched from "lb" * number of times to "ub" number of times * * note * if "ub" is INFINITY then "new" matches "lb" or more occurrences of "mach" */int mkrep( mach, lb, ub )int mach, lb, ub; { int base, tail, copy, i; base = copysingl( mach, lb - 1 ); if ( ub == INFINITY ) { copy = dupmachine( mach ); mach = link_machines( mach, link_machines( base, mkclos( copy ) ) ); } else { tail = mkstate( SYM_EPSILON ); for ( i = lb; i < ub; ++i ) { copy = dupmachine( mach ); tail = mkopt( link_machines( copy, tail ) ); } mach = link_machines( mach, link_machines( base, tail ) ); } return ( mach ); }/* mkstate - create a state with a transition on a given symbol * * synopsis * * state = mkstate( sym ); * * state - a new state matching sym * sym - the symbol the new state is to have an out-transition on * * note that this routine makes new states in ascending order through the * state array (and increments LASTNFA accordingly). The routine DUPMACHINE * relies on machines being made in ascending order and that they are * CONTIGUOUS. Change it and you will have to rewrite DUPMACHINE (kludge * that it admittedly is) */int mkstate( sym )int sym; { if ( ++lastnfa >= current_mns ) { if ( (current_mns += MNS_INCREMENT) >= MAXIMUM_MNS ) lerrif( "input rules are too complicated (>= %d NFA states)", current_mns ); ++num_reallocs; transchar = reallocate_integer_array( transchar, current_mns ); trans1 = reallocate_integer_array( trans1, current_mns ); trans2 = reallocate_integer_array( trans2, current_mns ); accptnum = reallocate_integer_array( accptnum, current_mns ); firstst = reallocate_integer_array( firstst, current_mns ); finalst = reallocate_integer_array( finalst, current_mns ); lastst = reallocate_integer_array( lastst, current_mns ); } transchar[lastnfa] = sym; trans1[lastnfa] = NO_TRANSITION; trans2[lastnfa] = NO_TRANSITION; accptnum[lastnfa] = NIL; firstst[lastnfa] = lastnfa; finalst[lastnfa] = lastnfa; lastst[lastnfa] = lastnfa; /* fix up equivalence classes base on this transition. Note that any * character which has its own transition gets its own equivalence class. * Thus only characters which are only in character classes have a chance * at being in the same equivalence class. E.g. "a|b" puts 'a' and 'b' * into two different equivalence classes. "[ab]" puts them in the same * equivalence class (barring other differences elsewhere in the input). */ if ( sym < 0 ) { /* we don't have to update the equivalence classes since that was * already done when the ccl was created for the first time */ } else if ( sym == SYM_EPSILON ) ++numeps; else { if ( useecs ) mkechar( sym, nextecm, ecgroup ); } return ( lastnfa ); }/* mkxtion - make a transition from one state to another * * synopsis * * mkxtion( statefrom, stateto ); * * statefrom - the state from which the transition is to be made * stateto - the state to which the transition is to be made */mkxtion( statefrom, stateto )int statefrom, stateto; { if ( trans1[statefrom] == NO_TRANSITION ) trans1[statefrom] = stateto; else if ( (transchar[statefrom] != SYM_EPSILON) || (trans2[statefrom] != NO_TRANSITION) ) flexfatal( "found too many transitions in mkxtion()" ); else { /* second out-transition for an epsilon state */ ++eps2; trans2[statefrom] = stateto; } } :MPW:MPW Tools:Tools with Source:Fast LEX:parse.y
/* parse.y - parser for flex input *//* * Copyright (c) 1987, the University of California * * The United States Government has rights in this work pursuant to * contract no. DE-AC03-76SF00098 between the United States Department of * Energy and the University of California. * * This program may be redistributed. Enhancements and derivative works * may be created provided the new works, if made available to the general * public, are made available for use by anyone. */%token CHAR NUMBER SECTEND SCDECL XSCDECL WHITESPACE NAME PREVCCL%{#include "flexdef.h"int pat, scnum, eps, headcnt, trailcnt, anyccl, lastchar, i, actvp, rulelen;int trlcontxt, xcluflg, cclsorted, varlength;char clower();static int madeany = false; /* whether we've made the '.' character class */%}%%goal : initlex sect1 sect1end sect2 ;initlex : { /* initialize for processing rules */ /* create default DFA start condition */ scinstal( "INITIAL", false ); } ; sect1 : sect1 startconddecl WHITESPACE namelist1 '\n' | | error '\n' { synerr( "unknown error processing section 1" ); } ;sect1end : SECTEND ;startconddecl : SCDECL { /* these productions are separate from the s1object * rule because the semantics must be done before * we parse the remainder of an s1object */ xcluflg = false; } | XSCDECL { xcluflg = true; } ;namelist1 : namelist1 WHITESPACE NAME { scinstal( nmstr, xcluflg ); } | NAME { scinstal( nmstr, xcluflg ); } | error { synerr( "bad start condition list" ); } ;sect2 : sect2 initforrule flexrule '\n' | ;initforrule : { /* initialize for a parse of one rule */ trlcontxt = varlength = false; trailcnt = headcnt = rulelen = 0; } ;flexrule : scon '^' re eol { pat = link_machines( $3, $4 ); add_accept( pat, headcnt, trailcnt ); for ( i = 1; i <= actvp; ++i ) scbol[actvsc[i]] = mkbranch( scbol[actvsc[i]], pat ); } | scon re eol { pat = link_machines( $2, $3 ); add_accept( pat, headcnt, trailcnt ); for ( i = 1; i <= actvp; ++i ) scset[actvsc[i]] = mkbranch( scset[actvsc[i]], pat ); } | '^' re eol { pat = link_machines( $2, $3 ); add_accept( pat, headcnt, trailcnt ); /* add to all non-exclusive start conditions, * including the default (0) start condition */ for ( i = 1; i <= lastsc; ++i ) if ( ! scxclu[i] ) scbol[i] = mkbranch( scbol[i], pat ); } | re eol { pat = link_machines( $1, $2 ); add_accept( pat, headcnt, trailcnt ); for ( i = 1; i <= lastsc; ++i ) if ( ! scxclu[i] ) scset[i] = mkbranch( scset[i], pat ); } | error { synerr( "unrecognized rule" ); } ;scon : '<' namelist2 '>' ;namelist2 : namelist2 ',' NAME { if ( (scnum = sclookup( nmstr )) == 0 ) synerr( "undeclared start condition" ); else actvsc[++actvp] = scnum; } | NAME { if ( (scnum = sclookup( nmstr )) == 0 ) synerr( "undeclared start condition" ); else actvsc[actvp = 1] = scnum; } | error { synerr( "bad start condition list" ); } ;eol : '$' { if ( trlcontxt ) { synerr( "trailing context used twice" ); $$ = mkstate( SYM_EPSILON ); } else { trlcontxt = true; if ( ! varlength ) headcnt = rulelen; ++rulelen; trailcnt = 1; eps = mkstate( SYM_EPSILON ); $$ = link_machines( eps, mkstate( '\n' ) ); } } | { $$ = mkstate( SYM_EPSILON ); if ( trlcontxt ) { if ( varlength && headcnt == 0 ) /* both head and trail are variable-length */ synerr( "illegal trailing context" ); else trailcnt = rulelen; } } ;re : re '|' series { varlength = true; $$ = mkor( $1, $3 ); } | re2 series { $$ = link_machines( $1, $2 ); } | series { $$ = $1; } ;re2 : re '/' { /* this rule is separate from the others for "re" so * that the reduction will occur before the trailing * series is parsed */ if ( trlcontxt ) synerr( "trailing context used twice" ); else trlcontxt = true; if ( varlength ) /* the trailing context had better be fixed-length */ varlength = false; else headcnt = rulelen; rulelen = 0; $$ = $1; } ;series : series singleton { /* this is where concatenation of adjacent patterns * gets done */ $$ = link_machines( $1, $2 ); } | singleton { $$ = $1; } ;singleton : singleton '*' { varlength = true; $$ = mkclos( $1 ); } | singleton '+' { varlength = true; $$ = mkposcl( $1 ); } | singleton '?' { varlength = true; $$ = mkopt( $1 ); } | singleton '{' NUMBER ',' NUMBER '}' { varlength = true; if ( $3 > $5 || $3 <= 0 ) { synerr( "bad iteration values" ); $$ = $1; } else $$ = mkrep( $1, $3, $5 ); } | singleton '{' NUMBER ',' '}' { varlength = true; if ( $3 <= 0 ) { synerr( "iteration value must be positive" ); $$ = $1; } else $$ = mkrep( $1, $3, INFINITY ); } | singleton '{' NUMBER '}' { /* the singleton could be something like "(foo)", * in which case we have no idea what its length * is, so we punt here. */ varlength = true; if ( $3 <= 0 ) { synerr( "iteration value must be positive" ); $$ = $1; } else $$ = link_machines( $1, copysingl( $1, $3 - 1 ) ); } | '.' { if ( ! madeany ) { /* create the '.' character class */ anyccl = cclinit(); ccladd( anyccl, '\n' ); cclnegate( anyccl ); if ( useecs ) mkeccl( ccltbl + cclmap[anyccl], ccllen[anyccl], nextecm, ecgroup, CSIZE ); madeany = true; } ++rulelen; $$ = mkstate( -anyccl ); } | fullccl { if ( ! cclsorted ) /* sort characters for fast searching. We use a * shell sort since this list could be large. */ cshell( ccltbl + cclmap[$1], ccllen[$1] ); if ( useecs ) mkeccl( ccltbl + cclmap[$1], ccllen[$1], nextecm, ecgroup, CSIZE ); ++rulelen; $$ = mkstate( -$1 ); } | PREVCCL { ++rulelen; $$ = mkstate( -$1 ); } | '"' string '"' { $$ = $2; } | '(' re ')' { $$ = $2; } | CHAR { ++rulelen; if ( $1 == '\0' ) synerr( "null in rule" ); if ( caseins && $1 >= 'A' && $1 <= 'Z' ) $1 = clower( $1 ); $$ = mkstate( $1 ); } ;fullccl : '[' ccl ']' { $$ = $2; } | '[' '^' ccl ']' { /* *Sigh* - to be compatible Unix lex, negated ccls * match newlines */#ifdef NOTDEF ccladd( $3, '\n' ); /* negated ccls don't match '\n' */ cclsorted = false; /* because we added the newline */#endif cclnegate( $3 ); $$ = $3; } ;ccl : ccl CHAR '-' CHAR { if ( $2 > $4 ) synerr( "negative range in character class" ); else { if ( caseins ) { if ( $2 >= 'A' && $2 <= 'Z' ) $2 = clower( $2 ); if ( $4 >= 'A' && $4 <= 'Z' ) $4 = clower( $4 ); } for ( i = $2; i <= $4; ++i ) ccladd( $1, i ); /* keep track if this ccl is staying in alphabetical * order */ cclsorted = cclsorted && ($2 > lastchar); lastchar = $4; } $$ = $1; } | ccl CHAR { if ( caseins ) if ( $2 >= 'A' && $2 <= 'Z' ) $2 = clower( $2 ); ccladd( $1, $2 ); cclsorted = cclsorted && ($2 > lastchar); lastchar = $2; $$ = $1; } | { cclsorted = true; lastchar = 0; $$ = cclinit(); } ;string : string CHAR { if ( caseins ) if ( $2 >= 'A' && $2 <= 'Z' ) $2 = clower( $2 ); ++rulelen; $$ = link_machines( $1, mkstate( $2 ) ); } | { $$ = mkstate( SYM_EPSILON ); } ;%%/* synerr - report a syntax error * * synopsis * char str[]; * synerr( str ); */synerr( str )char str[]; { syntaxerror = true;#ifdef MPW fprintf( stderr, "File %s ;Line %d # Syntax error: %s\n",infilename,linenum, str );#else fprintf( stderr, "Syntax error at line %d: %s\n", linenum, str );#endif }/* yyerror - eat up an error message from the parser * * synopsis * char msg[]; * yyerror( msg ); */yyerror( msg )char msg[]; { } :MPW:MPW Tools:Tools with Source:Fast LEX:scan.c.dist
:MPW:MPW Tools:Tools with Source:Fast LEX:scan.c.dist
+++++ Continued from previous card +++++
3, 24, 220, 3, 3, 71, 32, 3, 24, 24, 3, 33, 3, 3, 34, 55, 55, 216, 33, 213, 35, 34, 3, 3, 4, 4, 4, 35, 4, 4, 36, 4, 4, 37, 37, 4, 211, 36, 4, 59, 4, 4, 208, 4, 38, 38, 59, 83, 83, 37, 4, 4, 13, 48, 39, 39, 40, 40, 13, 39, 38, 40, 196, 13, 13, 13, 13, 13, 13, 14, 88, 48, 91, 48, 48, 14, 100, 88, 192, 91, 14, 14, 14, 14, 14, 14, 17, 100, 52, 52, 124, 189, 95, 52, 17, 108, 111, 17, 17, 95, 122, 122, 108, 111, 188, 122, 128, 128, 144, 144, 152, 139, 139, 17, 18, 52, 139, 124, 147, 147, 152, 145, 18, 155, 156, 18, 18, 145, 145, 157, 185, 156, 178, 155, 165, 165, 167, 167, 139, 157, 173, 18, 25, 25, 195, 195, 203, 25, 155, 195, 195, 173, 25, 197, 197, 202, 203, 206, 204, 210, 210, 177, 202, 161, 206, 218, 218, 25, 204, 25, 26, 26, 217, 217, 142, 26, 141, 217, 217, 136, 26, 219, 219, 221, 221, 225, 225, 134, 221, 221, 132, 130, 127, 125, 121, 26, 116, 26, 60, 60, 113, 110, 104, 101, 92, 77, 60, 60, 60, 60, 60, 60, 61, 61, 73, 69, 66, 61, 64, 63, 58, 49, 47, 61, 42, 28, 27, 16, 15, 9, 6, 5, 0, 0, 0, 0, 0, 0, 0, 61, 151, 151, 0, 0, 0, 0, 0, 0, 151, 151, 151, 151, 151, 151, 0, 0, 151, 153, 153, 0, 0, 0, 153, 0, 0, 0, 0, 0, 153, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 153, 227, 227, 227, 227, 227, 227, 227, 227, 227, 227, 228, 228, 228, 228, 228, 228, 228, 228, 228, 228, 229, 229, 229, 229, 229, 229, 229, 229, 229, 229, 230, 230, 230, 230, 230, 230, 230, 230, 230, 230, 231, 231, 231, 231, 231, 231, 231, 231, 231, 231, 232, 232, 232, 232, 232, 232, 232, 232, 232, 232, 233, 233, 0, 233, 233, 233, 233, 233, 233, 233, 234, 234, 234, 234, 234, 234, 234, 234, 234, 234, 235, 235, 235, 235, 235, 235, 235, 235, 235, 235, 236, 236, 0, 236, 236, 236, 236, 236, 236, 236, 237, 237, 0, 237, 237, 237, 237, 237, 237, 237, 238, 238, 238, 238, 238, 238, 238, 238, 238, 238, 239, 239, 239, 239, 239, 239, 239, 239, 239, 239, 240, 240, 240, 240, 240, 240, 240, 240, 240, 240, 241, 241, 241, 241, 241, 241, 241, 241, 241, 241, 242, 242, 242, 242, 242, 242, 242, 242, 242, 242, 243, 243, 243, 243, 243, 243, 243, 243, 243, 243, 244, 244, 244, 244, 244, 244, 244, 244, 244, 244, 246, 246, 246, 246, 246, 246, 246, 246, 246, 246, 247, 247, 247, 247, 247, 247, 247, 247, 247, 247, 248, 248, 248, 248, 248, 248, 248, 248, 248, 248, 250, 250, 0, 250, 250, 250, 250, 250, 0, 250, 251, 251, 0, 251, 251, 251, 251, 251, 251, 251, 252, 252, 0, 252, 252, 252, 252, 252, 252, 252, 253, 253, 253, 253, 253, 253, 253, 253, 253, 253, 254, 0, 0, 254, 254, 254, 254, 254, 254, 254, 255, 255, 0, 255, 255, 255, 255, 255, 255, 255, 257, 257, 0, 257, 257, 257, 257, 257, 257, 257, 258, 258, 0, 258, 258, 258, 258, 258, 258, 258, 259, 259, 0, 259, 259, 259, 259, 259, 0, 259, 260, 260, 0, 0, 0, 260, 260, 260, 260, 261, 261, 0, 261, 261, 261, 261, 261, 261, 261, 262, 262, 0, 262, 262, 0, 262, 262, 262, 262, 263, 263, 0, 0, 263, 263, 263, 0, 263, 263, 264, 264, 0, 264, 264, 264, 264, 264, 264, 264, 265, 265, 265, 265, 265, 265, 265, 265, 265, 265, 266, 266, 0, 266, 266, 266, 266, 266, 266, 266, 267, 267, 267, 267, 267, 267, 267, 267, 267, 267, 268, 268, 268, 268, 268, 268, 268, 268, 268, 268, 269, 269, 0, 269, 269, 269, 269, 269, 269, 270, 270, 270, 270, 270, 270, 270, 270, 270, 270, 271, 271, 0, 271, 271, 271, 271, 271, 271, 271, 272, 272, 272, 272, 272, 272, 272, 272, 272, 272, 273, 273, 273, 273, 273, 273, 273, 273, 273, 273, 274, 274, 274, 274, 274, 274, 274, 274, 274, 274, 275, 275, 0, 275, 275, 275, 275, 275, 275, 275, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226 } ;/* these declarations have to come after the section 1 code or lint gets * confused about whether the variables are used */FILE *yyin = stdin, *yyout = stdout;/* these variables are all declared out here so that section 3 code can * manipulate them */static int yy_start, yy_b_buf_p, yy_c_buf_p, yy_e_buf_p;static int yy_saw_eof, yy_init = 1;/* yy_ch_buf has to be 1 character longer than YY_BUF_SIZE, since when * setting up yytext we can try to put a '\0' just past the end of the * matched text */#ifdef MALLOC_BUFFERSstatic char *yy_ch_buf = 0L;static int *yy_st_buf = 0L;#elsestatic char yy_ch_buf[YY_BUF_SIZE + 1];static int yy_st_buf[YY_BUF_SIZE];#endifstatic char yy_hold_char;char *yytext;static int yyleng;YY_DECL { int yy_n_chars, yy_lp, yy_iii, yy_buf_pos, yy_act; static int bracelevel, didadef; int i, cclval; char nmdef[MAXLINE], myesc();#ifdef MALLOC_BUFFERS if(yy_ch_buf == 0L){ yy_ch_buf = (char *)malloc(YY_BUF_SIZE + 1); yy_st_buf = (int *)malloc(YY_BUF_SIZE * sizeof(int)); if(yy_ch_buf == 0L || yy_st_buf == 0L){ fprintf( stderr, "Out of memory\n"); exit(-1); } }#endif if ( yy_init ) { YY_INIT; yy_start = 1; yy_init = 0; } goto get_next_token;do_action: for ( ; ; ) { YY_DO_BEFORE_ACTION#ifdef FLEX_DEBUG fprintf( stderr, "--accepting rule #%d\n", yy_act );#endif switch ( yy_act ) {case 1:# line 58 "scan.l"++linenum; ECHO; /* indented code */ YY_BREAKcase 2:# line 59 "scan.l"++linenum; ECHO; /* treat as a comment */ YY_BREAKcase 3:# line 60 "scan.l"ECHO; BEGIN(C_COMMENT); YY_BREAKcase 4:# line 61 "scan.l"return ( SCDECL ); YY_BREAKcase 5:# line 62 "scan.l"return ( XSCDECL ); YY_BREAKcase 6:# line 63 "scan.l"++linenum; line_directive_out( stdout ); BEGIN(CODEBLOCK); YY_BREAKcase 7:# line 64 "scan.l"return ( WHITESPACE ); YY_BREAKcase 8:# line 66 "scan.l"{ sectnum = 2; line_directive_out( stdout ); BEGIN(SECT2PROLOG); return ( SECTEND ); } YY_BREAKcase 9:# line 73 "scan.l"{ fprintf( stderr, "old-style lex command at line %d ignored:\n\t%s", linenum, yytext ); ++linenum; } YY_BREAKcase 10:# line 80 "scan.l"{ (void) strcpy( nmstr, yytext ); didadef = false; BEGIN(PICKUPDEF); } YY_BREAKcase 11:# line 86 "scan.l"RETURNNAME; YY_BREAKcase 12:# line 87 "scan.l"++linenum; /* allows blank lines in section 1 */ YY_BREAKcase 13:# line 88 "scan.l"++linenum; return ( '\n' ); YY_BREAKcase 14:# line 89 "scan.l"synerr( "illegal character" ); BEGIN(RECOVER); YY_BREAKcase 15:# line 92 "scan.l"ECHO; BEGIN(0); YY_BREAKcase 16:# line 93 "scan.l"++linenum; ECHO; BEGIN(0); YY_BREAKcase 17:# line 94 "scan.l"ECHO; YY_BREAKcase 18:# line 95 "scan.l"ECHO; YY_BREAKcase 19:# line 96 "scan.l"++linenum; ECHO; YY_BREAKcase 20:# line 98 "scan.l"++linenum; BEGIN(0); YY_BREAKcase 21:# line 99 "scan.l"++linenum; ECHO; YY_BREAKcase 22:# line 101 "scan.l"/* separates name and definition */ YY_BREAKcase 23:# line 103 "scan.l"{ (void) strcf, yytext ); for ( i = strlen( nmdef ) - 1; i >= 0 && nmdef[i] == ' ' || nmdef[i] == '\t'; --i ) ; nmdef[i + 1] = '\0'; ndinstal( nmstr, nmdef ); didadef = true; } YY_BREAKcase 24:# line 118 "scan.l"{ if ( ! didadef ) synerr( "incomplete name definition" ); BEGIN(0); ++linenum; } YY_BREAKcase 25:# line 125 "scan.l"++linenum; BEGIN(0); RETURNNAME; YY_BREAKcase 26:YY_DO_BEFORE_SCAN; /* undo effects of setting up yytext */yy_c_buf_p -= 1;YY_DO_BEFORE_ACTION; /* set up yytext again */# line 128 "scan.l"{ ++linenum; ACTION_ECHO; MARK_END_OF_PROLOG; BEGIN(SECT2); } YY_BREAKcase 27:# line 135 "scan.l"++linenum; ACTION_ECHO; YY_BREAKcase 28:# line 137 "scan.l"++linenum; /* allow blank lines in section 2 */ YY_BREAK /* this horrible mess of a rule matches indented lines which * do not contain "/*". We need to make the distinction because * otherwise this rule will be taken instead of the rule which * matches the beginning of comments like this one */case 29:# line 144 "scan.l"{ synerr( "indented code found outside of action" ); ++linenum; } YY_BREAKcase 30:# line 149 "scan.l"BEGIN(SC); return ( '<' ); YY_BREAKcase 31:# line 150 "scan.l"return ( '^' ); YY_BREAKcase 32:# line 151 "scan.l"BEGIN(QUOTE); return ( '"' ); YY_BREAKcase 33:YY_DO_BEFORE_SCAN; /* undo effects of setting up yytext */yy_c_buf_p = yy_b_buf_p;YY_DO_BEFORE_ACTION; /* set up yytext again */# line 152 "scan.l"BEGIN(NUM); return ( '{' ); YY_BREAKcase 34:# line 153 "scan.l"BEGIN(BRACEERROR); YY_BREAKcase 35:YY_DO_BEFORE_SCAN; /* undo effects of setting up yytext */yy_c_buf_p = yy_b_buf_p;YY_DO_BEFORE_ACTION; /* set up yytext again */# line 154 "scan.l"return ( '$' ); YY_BREAKcase 36:# line 156 "scan.l"{ bracelevel = 1; BEGIN(PERCENT_BRACE_ACTION); return ( '\n' ); } YY_BREAKcase 37:# line 161 "scan.l"++linenum; return ( '\n' ); YY_BREAKcase 38:# line 163 "scan.l"ACTION_ECHO; BEGIN(C_COMMENT_2); YY_BREAKcase 39:# line 165 "scan.l"{ /* needs to be separate from following rule due to * bug with trailing context */ bracelevel = 0; BEGIN(ACTION); return ( '\n' ); } YY_BREAKcase 40:YY_DO_BEFORE_SCAN; /* undo effects of setting up yytext */yy_c_buf_p -= 1;YY_DO_BEFORE_ACTION; /* set up yytext again */# line 173 "scan.l"{ bracelevel = 0; BEGIN(ACTION); return ( '\n' ); } YY_BREAKcase 41:# line 179 "scan.l"++linenum; return ( '\n' ); YY_BREAKcase 42:# line 181 "scan.l"{ /* guarantee that the SECT3 rule will have something * to match */ yyless(1); sectnum = 3; BEGIN(SECT3); return ( EOF ); /* to stop the parser */ } YY_BREAKcase 43:# line 191 "scan.l"{ (void) strcpy( nmstr, yytext ); /* check to see if we've already encountered this ccl */ if ( (cclval = ccllookup( nmstr )) ) { yylval = cclval; ++cclreuse; return ( PREVCCL ); } else { /* we fudge a bit. We know that this ccl will * soon be numbered as lastccl + 1 by cclinit */ cclinstal( nmstr, lastccl + 1 ); /* push back everything but the leading bracket * so the ccl can be rescanned */ PUT_BACK_STRING(nmstr, 1); BEGIN(FIRSTCCL); return ( '[' ); } } YY_BREAKcase 44:# line 218 "scan.l"{ register char *nmdefptr; char *ndlookup(); (void) strcpy( nmstr, yytext ); nmstr[yyleng - 1] = '\0'; /* chop trailing brace */ /* lookup from "nmstr + 1" to chop leading brace */ if ( ! (nmdefptr = ndlookup( nmstr + 1 )) ) synerr( "undefined {name}" ); else { /* push back name surrounded by ()'s */ unput(')'); PUT_BACK_STRING(nmdefptr, 0); unput('('); } } YY_BREAKcase 45:# line 237 "scan.l"return ( yytext[0] ); YY_BREAKcase 46:# line 238 "scan.l"RETURNCHAR; YY_BREAKcase 47:# line 239 "scan.l"++linenum; return ( '\n' ); YY_BREAKcase 48:# line 242 "scan.l"return ( ',' ); YY_BREAKcase 49:# line 243 "scan.l"BEGIN(SECT2); return ( '>' ); YY_BREAKcase 50:YY_DO_BEFORE_SCAN; /* undo effects of setting up yytext */yy_c_buf_p = yy_b_buf_p;YY_DO_BEFORE_ACTION; /* set up yytext again */# line 244 "scan.l"BEGIN(CARETISBOL); return ( '>' ); YY_BREAKcase 51:# line 245 "scan.l"RETURNNAME; YY_BREAKcase 52:# line 246 "scan.l"synerr( "bad start condition name" ); YY_BREAKcase 53:# line 248 "scan.l"BEGIN(SECT2); return ( '^' ); YY_BREAKcase 54:# line 251 "scan.l"RETURNCHAR; YY_BREAKcase 55:# line 252 "scan.l"BEGIN(SECT2); return ( '"' ); YY_BREAKcase 56:# line 254 "scan.l"{ synerr( "missing quote" ); BEGIN(SECT2); ++linenum; return ( '"' ); } YY_BREAKcase 57:YY_DO_BEFORE_SCAN; /* undo effects of setting up yytext */yy_c_buf_p = yy_b_buf_p;YY_DO_BEFORE_ACTION; /* set up yytext again */# line 262 "scan.l"BEGIN(CCL); return ( '^' ); YY_BREAKcase 58:YY_DO_BEFORE_SCAN; /* undo effects of setting up yytext */yy_c_buf_p = yy_b_buf_p;YY_DO_BEFORE_ACTION; /* set up yytext again */# line 263 "scan.l"return ( '^' ); YY_BREAKcase 59:# line 264 "scan.l"BEGIN(CCL); yylval = '-'; return ( CHAR ); YY_BREAKcase 60:# line 265 "scan.l"BEGIN(CCL); RETURNCHAR; YY_BREAKcase 61:YY_DO_BEFORE_SCAN; /* undo effects of setting up yytext */yy_c_buf_p = yy_b_buf_p;YY_DO_BEFORE_ACTION; /* set up yytext again */# line 267 "scan.l"return ( '-' ); YY_BREAKcase 62:# line 268 "scan.l"RETURNCHAR; YY_BREAKcase 63:# line 269 "scan.l"BEGIN(SECT2); return ( ']' ); YY_BREAKcase 64:# line 272 "scan.l"{ yylval = myctoi( yytext ); return ( NUMBER ); } YY_BREAKcase 65:# line 277 "scan.l"return ( ',' ); YY_BREAKcase 66:# line 278 "scan.l"BEGIN(SECT2); return ( '}' ); YY_BREAKcase 67:# line 280 "scan.l"{ synerr( "bad character inside {}'s" ); BEGIN(SECT2); return ( '}' ); } YY_BREAKcase 68:# line 286 "scan.l"{ synerr( "missing }" ); BEGIN(SECT2); ++linenum; return ( '}' ); } YY_BREAKcase 69:# line 294 "scan.l"synerr( "bad name in {}'s" ); BEGIN(SECT2); YY_BREAKcase 70:# line 295 "scan.l"synerr( "missing }" ); ++linenum; BEGIN(SECT2); YY_BREAKcase 71:# line 298 "scan.l"bracelevel = 0; YY_BREAKcase 72:# line 299 "scan.l"ACTION_ECHO; YY_BREAKcase 73:# line 300 "scan.l"{ ++linenum; ACTION_ECHO; if ( bracelevel == 0 ) { fputs( "\tYY_BREAK\n", temp_action_file ); BEGIN(SECT2); } } YY_BREAKcase 74:# line 310 "scan.l"ACTION_ECHO; ++bracelevel; YY_BREAKcase 75:# line 311 "scan.l"ACTION_ECHO; --bracelevel; YY_BREAKcase 76:# line 312 "scan.l"ACTION_ECHO; YY_BREAKcase 77:# line 313 "scan.l"ACTION_ECHO; BEGIN(ACTION_COMMENT); YY_BREAKcase 78:# line 314 "scan.l"ACTION_ECHO; /* character constant */ YY_BREAKcase 79:# line 315 "scan.l"ACTION_ECHO; BEGIN(ACTION_STRING); YY_BREAKcase 80:# line 316 "scan.l"{ ++linenum; ACTION_ECHO; if ( bracelevel == 0 ) { fputs( "\tYY_BREAK\n", temp_action_file ); BEGIN(SECT2); } } YY_BREAKcase 81:# line 325 "scan.l"ACTION_ECHO; YY_BREAKcase 82:# line 327 "scan.l"ACTION_ECHO; BEGIN(ACTION); YY_BREAKcase 83:# line 328 "scan.l"ACTION_ECHO; YY_BREAKcase 84:# line 329 "scan.l"ACTION_ECHO; YY_BREAKcase 85:# line 330 "scan.l"++linenum; ACTION_ECHO; YY_BREAKcase 86:# line 331 "scan.l"ACTION_ECHO; YY_BREAKcase 87:# line 333 "scan.l"ACTION_ECHO; BEGIN(SECT2); YY_BREAKcase 88:# line 334 "scan.l"++linenum; ACTION_ECHO; BEGIN(SECT2); YY_BREAKcase 89:# line 335 "scan.l"ACTION_ECHO; YY
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:Fast LEX:scan.c.dist
+++++ Continued from previous card +++++
_BREAKcase 90:# line 336 "scan.l"ACTION_ECHO; YY_BREAKcase 91:# line 337 "scan.l"++linenum; ACTION_ECHO; YY_BREAKcase 92:# line 339 "scan.l"ACTION_ECHO; YY_BREAKcase 93:# line 340 "scan.l"ACTION_ECHO; YY_BREAKcase 94:# line 341 "scan.l"++linenum; ACTION_ECHO; YY_BREAKcase 95:# line 342 "scan.l"ACTION_ECHO; BEGIN(ACTION); YY_BREAKcase 96:# line 343 "scan.l"ACTION_ECHO; YY_BREAKcase 97:# line 346 "scan.l"{ yylval = myesc( yytext ) & BYTEMASK; return ( CHAR ); } YY_BREAKcase 98:# line 351 "scan.l"{ yylval = myesc( yytext ) & BYTEMASK; BEGIN(CCL); return ( CHAR ); } YY_BREAKcase 99:# line 358 "scan.l"{ register int numchars; /* black magic - we know the names of a flex scanner's * internal variables. We cap the input buffer with * an end-of-string and dump it to the output. */ YY_DO_BEFORE_SCAN; /* recover from setting up yytext */#ifdef FLEX_FAST_SKEL fputs( yy_c_buf_p + 1, stdout );#else yy_ch_buf[yy_e_buf_p + 1] = '\0'; /* ignore the first character; it's the second '%' * put back by the yyless(1) above */ fputs( yy_ch_buf + yy_c_buf_p + 1, stdout );#endif /* if we don't do this, the data written by write() * can get overwritten when stdout is finally flushed */ (void) fflush( stdout ); while ( (numchars = read( fileno(yyin), yy_ch_buf, YY_BUF_MAX )) > 0 ) (void) write( fileno(stdout), yy_ch_buf, numchars ); if ( numchars < 0 ) flexerror( "fatal read error in section 3" ); return ( EOF ); } YY_BREAKcase YY_NEW_FILE:break; /* begin reading from new file */case YY_DO_DEFAULT:YY_DEFAULT_ACTION;break;case YY_END_TOK:return ( YY_END_TOK );default:YY_FATAL_ERROR( "fatal flex scanner internal error" ); }get_next_token: { register int yy_curst; register char yy_sym; YY_DO_BEFORE_SCAN /* set up to begin running DFA */ yy_curst = yy_start; if ( yy_ch_buf[yy_c_buf_p] == '\n' ) ++yy_curst; /* yy_b_buf_p points to the position in yy_ch_buf * of the start of the current run. */ yy_b_buf_p = yy_c_buf_p + 1; do /* until the machine jams */ { if ( yy_c_buf_p == yy_e_buf_p ) { /* need more input */ if ( yy_e_buf_p >= YY_BUF_LIM ) { /* not enough room to do another read */ /* see if we can make some room for more chars */ yy_n_chars = yy_e_buf_p - yy_b_buf_p; if ( yy_n_chars >= 0 ) /* shift down buffer to make room */ for ( yy_iii = 0; yy_iii <= yy_n_chars; ++yy_iii ) { yy_buf_pos = yy_b_buf_p + yy_iii; yy_ch_buf[yy_iii] = yy_ch_buf[yy_buf_pos]; yy_st_buf[yy_iii] = yy_st_buf[yy_buf_pos]; } yy_b_buf_p = 0; yy_e_buf_p = yy_n_chars; if ( yy_e_buf_p >= YY_BUF_LIM ) YY_FATAL_ERROR( "flex input buffer overflowed" ); yy_c_buf_p = yy_e_buf_p; } else if ( yy_saw_eof ) {saweof: if ( yy_b_buf_p > yy_e_buf_p ) { if ( yywrap() ) { yy_act = YY_END_TOK; goto do_action; } else { YY_INIT; yy_act = YY_NEW_FILE; goto do_action; } } else /* do a jam to eat up more input */ {#ifndef FLEX_INTERACTIVE_SCANNER /* we're going to decrement yy_c_buf_p upon doing * the jam. In this case, that's wrong, since * it points to the last non-jam character. So * we increment it now to counter the decrement. */ ++yy_c_buf_p;#endif break; } } YY_INPUT( (yy_ch_buf + yy_c_buf_p + 1), yy_n_chars, YY_MAX_LINE ); if ( yy_n_chars == YY_NULL ) { if ( yy_saw_eof ) YY_FATAL_ERROR( "flex scanner saw EOF twice - shouldn't happen" ); yy_saw_eof = 1; goto saweof; } yy_e_buf_p += yy_n_chars; } ++yy_c_buf_p;#ifdef FLEX_USE_ECS yy_sym = e[(yy_ch_buf[yy_c_buf_p] & BYTEMASK)];#else yy_sym = yy_ch_buf[yy_c_buf_p];#endif#ifdef FLEX_FULL_TABLE yy_curst = n[yy_curst][yy_sym];#else /* get next state from compressed table */ while ( c[b[yy_curst] + yy_sym] != yy_curst ) { yy_curst = d[yy_curst];#ifdef FLEX_USE_MECS /* we've arrange it so that templates are never chained * to one another. This means we can afford make a * very simple test to see if we need to convert to * yy_sym's meta-equivalence class without worrying * about erroneously looking up the meta-equivalence * class twice */ if ( yy_curst >= YY_TEMPLATE ) yy_sym = m[yy_sym];#endif } yy_curst = n[b[yy_curst] + yy_sym];#endif yy_st_buf[yy_c_buf_p] = yy_curst; }#ifdef FLEX_INTERACTIVE_SCANNER while ( b[yy_curst] != YY_JAM_BASE );#else while ( yy_curst != YY_JAM ); --yy_c_buf_p; /* put back character we jammed on */#endif if ( yy_c_buf_p >= yy_b_buf_p ) { /* we matched some text */ yy_curst = yy_st_buf[yy_c_buf_p]; yy_lp = l[yy_curst];#ifdef FLEX_REJECT_ENABLEDfind_rule: /* we branch to this label when doing a REJECT */#endif for ( ; ; ) /* until we find what rule we matched */ {#ifdef FLEX_REJECT_ENABLED if ( yy_lp && yy_lp < l[yy_curst + 1] ) { yy_act = a[yy_lp]; goto do_action; /* "continue 2" */ }#else if ( yy_lp ) { yy_act = yy_lp; goto do_action; /* "continue 2" */ }#endif if ( --yy_c_buf_p < yy_b_buf_p ) break; yy_curst = yy_st_buf[yy_c_buf_p]; yy_lp = l[yy_curst]; } } /* if we got this far, then we didn't find any accepting * states */ /* so that the default applies to the first char read */ ++yy_c_buf_p; yy_act = YY_DO_DEFAULT; } } /*NOTREACHED*/ }static int unput( c )char c; { YY_DO_BEFORE_SCAN; /* undo effects of setting up yytext */ if ( yy_c_buf_p == 0 ) { register int i; register int yy_buf_pos = YY_BUF_MAX; for ( i = yy_e_buf_p; i >= yy_c_buf_p; --i ) { yy_ch_buf[yy_buf_pos] = yy_ch_buf[i]; yy_st_buf[yy_buf_pos] = yy_st_buf[i]; --yy_buf_pos; } yy_c_buf_p = YY_BUF_MAX - yy_e_buf_p; yy_e_buf_p = YY_BUF_MAX; } if ( yy_c_buf_p <= 0 ) YY_FATAL_ERROR( "flex scanner push-back overflow" ); if ( yy_c_buf_p >= yy_b_buf_p && yy_ch_buf[yy_c_buf_p] == '\n' ) yy_ch_buf[yy_c_buf_p - 1] = '\n'; yy_ch_buf[yy_c_buf_p--] = c; YY_DO_BEFORE_ACTION; /* set up yytext again */ }static int input() { int c; YY_DO_BEFORE_SCAN if ( yy_c_buf_p == yy_e_buf_p ) { /* need more input */ int yy_n_chars; /* we can throw away the entire current buffer */ if ( yy_saw_eof ) { if ( yywrap() ) return ( EOF ); YY_INIT; } yy_b_buf_p = 0; YY_INPUT( yy_ch_buf, yy_n_chars, YY_MAX_LINE ); if ( yy_n_chars == YY_NULL ) { yy_saw_eof = 1; if ( yywrap() ) return ( EOF ); YY_INIT; return ( input() ); } yy_c_buf_p = -1; yy_e_buf_p = yy_n_chars - 1; } c = yy_ch_buf[++yy_c_buf_p]; YY_DO_BEFORE_ACTION; return ( c & BYTEMASK); }# line 392 "scan.l" :MPW:MPW Tools:Tools with Source:Fast LEX:scan.l
/* scan.l - scanner for flex input *//* * Copyright (c) 1987, the University of California * * The United States Government has rights in this work pursuant to * contract no. DE-AC03-76SF00098 between the United States Department of * Energy and the University of California. * * This program may be redistributed. Enhancements and derivative works * may be created provided the new works, if made available to the general * public, are made available for use by anyone. */%{#include "flexdef.h"#include "parse.h"#define ACTION_ECHO fprintf( temp_action_file, "%s", yytext )#define MARK_END_OF_PROLOG fprintf( temp_action_file, "%%%% end of prolog\n" );#undef YY_DECL#define YY_DECL \ int flexscan()#define RETURNCHAR \ yylval = yytext[0] & BYTEMASK; \ return ( CHAR );#define RETURNNAME \ (void) strcpy( nmstr, yytext ); \ return ( NAME );#define PUT_BACK_STRING(str, start) \ for ( i = strlen( str ) - 1; i >= start; --i ) \ unput(str[i])%}%x SECT2 SECT2PROLOG SECT3 CODEBLOCK PICKUPDEF SC CARETISBOL NUM QUOTE%x FIRSTCCL CCL ACTION RECOVER BRACEERROR C_COMMENT C_COMMENT_2 ACTION_COMMENT%x ACTION_STRING PERCENT_BRACE_ACTIONWS [ \t]+OPTWS [ \t]*NAME [a-z_][a-z_0-9]*SCNAME {NAME}ESCSEQ \\([^^\n]|"^".|0[0-9]{1,3})%% static int bracelevel, didadef; int i, cclval; char nmdef[MAXLINE], myesc();^{WS}.*\n ++linenum; ECHO; /* indented code */^#.*\n ++linenum; ECHO; /* treat as a comment */^"/*" ECHO; BEGIN(C_COMMENT);^"%s"(tart)? return ( SCDECL );^"%x" return ( XSCDECL );^"%{".*\n ++linenum; line_directive_out( stdout ); BEGIN(CODEBLOCK);{WS} return ( WHITESPACE );^"%%".* { sectnum = 2; line_directive_out( stdout ); BEGIN(SECT2PROLOG); return ( SECTEND ); }^"%"[^sx{%].*\n { fprintf( stderr, "old-style lex command at line %d ignored:\n\t%s", linenum, yytext ); ++linenum; }^{NAME} { (void) strcpy( nmstr, yytext ); didadef = false; BEGIN(PICKUPDEF); }{SCNAME} RETURNNAME;^{OPTWS}\n ++linenum; /* allows blank lines in section 1 */\n ++linenum; return ( '\n' );. synerr( "illegal character" ); BEGIN(RECOVER);<C_COMMENT>"*/" ECHO; BEGIN(0);<C_COMMENT>"*/".*\n ++linenum; ECHO; BEGIN(0);<C_COMMENT>[^*\n]+ ECHO;<C_COMMENT>"*" ECHO;<C_COMMENT>\n ++linenum; ECHO;<CODEBLOCK>^"%}".*\n ++linenum; BEGIN(0);<CODEBLOCK>.*\n ++linenum; ECHO;<PICKUPDEF>{WS} /* separates name and definition */<PICKUPDEF>[^ \t\n].* { (void) strcpy( nmdef, yytext ); for ( i = strlen( nmdef ) - 1; i >= 0 && nmdef[i] == ' ' || nmdef[i] == '\t'; --i ) ; nmdef[i + 1] = '\0'; ndinstal( nmstr, nmdef ); didadef = true; }<PICKUPDEF>\n { if ( ! didadef ) synerr( "incomplete name definition" ); BEGIN(0); ++linenum; }<RECOVER>.*\n ++linenum; BEGIN(0); RETURNNAME;<SECT2PROLOG>.*\n/[^ \t\n] { ++linenum; ACTION_ECHO; MARK_END_OF_PROLOG; BEGIN(SECT2); }<SECT2PROLOG>.*\n ++linenum; ACTION_ECHO;<SECT2>^{OPTWS}\n ++linenum; /* allow blank lines in section 2 */ /* this horrible mess of a rule matches indented lines which * do not contain "/*". We need to make the distinction because * otherwise this rule will be taken instead of the rule which * matches the beginning of comments like this one */<SECT2>^{WS}([^/\n]|"/"[^*\n])*("/"?)\n { synerr( "indented code found outside of action" ); ++linenum; }<SECT2>"<" BEGIN(SC); return ( '<' );<SECT2>^"^" return ( '^' );<SECT2>\" BEGIN(QUOTE); return ( '"' );<SECT2>"{"/[0-9] BEGIN(NUM); return ( '{' );<SECT2>"{"[^0-9\n][^}\n]* BEGIN(BRACEERROR);<SECT2>"$"/[ \t\n] return ( '$' );<SECT2>{WS}"%{" { bracelevel = 1; BEGIN(PERCENT_BRACE_ACTION); return ( '\n' ); }<SECT2>{WS}"|".*\n ++linenum; return ( '\n' );<SECT2>^{OPTWS}"/*" ACTION_ECHO; BEGIN(C_COMMENT_2);<SECT2>{WS} { /* needs to be separate from following rule due to * bug with trailing context */ bracelevel = 0; BEGIN(ACTION); return ( '\n' ); }<SECT2>{OPTWS}/\n { bracelevel = 0; BEGIN(ACTION); return ( '\n' ); }<SECT2>^{OPTWS}\n ++linenum; return ( '\n' );<SECT2>^"%%".* { /* guarantee that the SECT3 rule will have something * to match */ yyless(1); sectnum = 3; BEGIN(SECT3); return ( EOF ); /* to stop the parser */ }<SECT2>"["([^\\\]\n]|{ESCSEQ})+"]" { (void) strcpy( nmstr, yytext ); /* check to see if we've already encountered this ccl */ if ( (cclval = ccllookup( nmstr )) ) { yylval = cclval; ++cclreuse; return ( PREVCCL ); } else { /* we fudge a bit. We know that this ccl will * soon be numbered as lastccl + 1 by cclinit */ cclinstal( nmstr, lastccl + 1 ); /* push back everything but the leading bracket * so the ccl can be rescanned */ PUT_BACK_STRING(nmstr, 1); BEGIN(FIRSTCCL); return ( '[' ); } }<SECT2>"{"{NAME}"}" { register char *nmdefptr; char *ndlookup(); (void) strcpy( nmstr, yytext ); nmstr[yyleng - 1] = '\0'; /* chop trailing brace */ /* lookup from "nmstr + 1" to chop leading brace */ if ( ! (nmdefptr = ndlookup( nmstr + 1 )) ) synerr( "undefined {name}" ); else { /* push back name surrounded by ()'s */ unput(')'); PUT_BACK_STRING(nmdefptr, 0); unput('('); } }<SECT2>[/|*+?.()] return ( yytext[0] );<SECT2>. RETURNCHAR;<SECT2>\n ++linenum; return ( '\n' );<SC>"," return ( ',' );<SC>">" BEGIN(SECT2); return ( '>' );<SC>">"/"^" BEGIN(CARETISBOL); return ( '>' );<SC>{SCNAME} RETURNNAME;<SC>. synerr( "bad start condition name" );<CARETISBOL>"^" BEGIN(SECT2); return ( '^' );<QUOTE>[^"\n] RETURNCHAR;<QUOTE>\" BEGIN(SECT2); return ( '"' );<QUOTE>\n { synerr( "missing quote" ); BEGIN(SECT2); ++linenum; return ( '"' ); }<FIRSTCCL>"^"/[^-\n] BEGIN(CCL); return ( '^' );<FIRSTCCL>"^"/- return ( '^' );<FIRSTCCL>- BEGIN(CCL); yylval = '-'; return ( CHAR );<FIRSTCCL>. BEGIN(CCL); RETURNCHAR;<CCL>-/[^\]\n] return ( '-' );<CCL>[^\]\n] RETURNCHAR;<CCL>"]" BEGIN(SECT2); return ( ']' );<NUM>[0-9]+ { yylval = myctoi( yytext ); return ( NUMBER ); }<NUM>"," return ( ',' );<NUM>"}" BEGIN(SECT2); return ( '}' );<NUM>. { synerr( "bad character inside {}'s" ); BEGIN(SECT2); return ( '}' ); }<NUM>\n { synerr( "missing }" ); BEGIN(SECT2); ++linenum; return ( '}' ); }<BRACEERROR>"}" synerr( "bad name in {}'s" ); BEGIN(SECT2);<BRACEERROR>\n synerr( "missing }" ); ++linenum; BEGIN(SECT2);<PERCENT_BRACE_ACTION>{OPTWS}"%}".* bracelevel = 0;<PERCENT_BRACE_ACTION>.* ACTION_ECHO;<PERCENT_BRACE_ACTION>\n { ++linenum; ACTION_ECHO; if ( bracelevel == 0 ) { fputs( "\tYY_BREAK\n", temp_action_file ); BEGIN(SECT2); } }<ACTION>"{" ACTION_ECHO; ++bracelevel;<ACTION>"}" ACTION_ECHO; --bracelevel;<ACTION>[^{}"'/\n]+ ACTION_ECHO;<ACTION>"/*" ACTION_ECHO; BEGIN(ACTION_COMMENT);<ACTION>"'"([^'\\\n]|\\.)*"'" ACTION_ECHO; /* character constant */<ACTION>\" ACTION_ECHO; BEGIN(ACTION_STRING);<ACTION>\n { ++linenum; ACTION_ECHO; if ( bracelevel == 0 ) { fputs( "\tYY_BREAK\n", temp_action_file ); BEGIN(SECT2); } }<ACTION>. ACTION_ECHO;<ACTION_COMMENT>"*/" ACTION_ECHO; BEGIN(ACTION);<ACTION_COMMENT>[^*\n]+ ACTION_ECHO;<ACTION_COMMENT>"*" ACTION_ECHO;<ACTION_COMMENT>\n ++linenum; ACTION_ECHO;<ACTION_COMMENT>. ACTION_ECHO;<C_COMMENT_2>"*/" ACTION_ECHO; BEGIN(SECT2);<C_COMMENT_2>"*/".*\n ++linenum; ACTION_ECHO; BEGIN(SECT2);<C_COMMENT_2>[^*\n]+ ACTION_ECHO;<C_COMMENT_2>"*" ACTION_ECHO;<C_COMMENT_2>\n ++linenum; ACTION_ECHO;<ACTION_STRING>[^"\\\n]+ ACTION_ECHO;<ACTION_STRING>\\. ACTION_ECHO;<ACTION_STRING>\n ++linenum; ACTION_ECHO;<ACTION_STRING>\" ACTION_ECHO; BEGIN(ACTION);<ACTION_STRING>. ACTION_ECHO;<SECT2,QUOTE,CCL>{ESCSEQ} { yylval = myesc( yytext ) & BYTEMASK; return ( CHAR ); }<FIRSTCCL>{ESCSEQ} { yylval = myesc( yytext ) & BYTEMASK; BEGIN(CCL); return ( CHAR ); }<SECT3>.|\n { register int numchars; /* black magic - we know the names of a flex scanner's * internal variables. We cap the input buffer with * an end-of-string and dump it to the output. */ YY_DO_BEFORE_SCAN; /* recover from setting up yytext */#ifdef FLEX_FAST_SKEL fputs( yy_c_buf_p + 1, stdout );#else yy_ch_buf[yy_e_buf_p + 1] = '\0'; /* ignore the first character; it's the second '%' * put back by the yyless(1) above */ fputs( yy_ch_buf + yy_c_buf_p + 1, stdout );#endif /* if we don't do this, the data written by write() * can get overwritten when stdout is finally flushed */ (void) fflush( stdout ); while ( (numchars = read( fileno(yyin), yy_ch_buf, YY_BUF_MAX )) > 0 ) (void) write( fileno(stdout), yy_ch_buf, numchars ); if ( numchars < 0 ) flexerror( "fatal read error in section 3" ); return ( EOF ); }%% :MPW:MPW Tools:Tools with Source:Fast LEX:sym.c
/* sym - symbol table routines *//* * Copyright (c) 1987, the University of California * * The United States Government has rights in this work pursuant to * contract no. DE-AC03-76SF00098 between the United States Department of * Energy and the University of California. * * This program may be redistributed. Enhancements and derivative works * may be created provided the new works, if made available to the general * public, are made available for use by anyone. */#include "flexdef.h"/* * MPW C 2.0.2 does not like variables named "entry". */#ifdef MPW#define entry entry_by_another_name#endifstruct hash_entry *ndtbl[NAME_TABLE_HASH_SIZE];struct hash_entry *sctbl[START_COND_HASH_SIZE];struct hash_entry *ccltab[CCL_HASH_SIZE];struct hash_entry *findsym();/* addsym - add symbol and definitions to symbol table * * synopsis * char sym[], *str_def; * int int_def; * hash_table table; * int table_size; * 0 / -1 = addsym( sym, def, int_def, table, table_size ); * * -1 is returned if the symbol already exists, and the change not made. */int addsym( sym, str_def, int_def, table, table_size )register char sym[];char *str_def;int int_def;hash_table table;int table_size; { int hash_val = hashfunct( sym, table_size ); register struct hash_entry *entry = table[hash_val]; register struct hash_entry *new_entry; register struct hash_entry *successor; char *malloc(); while ( entry ) { if ( ! strcmp( sym, entry->name ) ) { /* entry already exists */ return ( -1 ); } entry = entry->next; } /* create new entry */ new_entry = (struct hash_entry *) malloc( sizeof( struct hash_entry ) ); if ( new_entry == NULL ) flexfatal( "symbol table memory allocation failed" ); if ( (successor = table[hash_val]) ) { new_entry->next = successor; successor->prev = new_entry; } else new_entry->next = NULL; new_entry->prev = NULL; new_entry->name = sym; new_entry->str_val = str_def; new_entry->int_val = int_def; table[hash_val] = new_entry; return ( 0 ); }/* cclinstal - save the text of a character class * * synopsis * char ccltxt[]; * int cclnum; * cclinstal( ccltxt, cclnum ); */cclinstal( ccltxt, cclnum )char ccltxt[];int cclnum; { /* we don't bother checking the return status because we are not called * unless the symbol is new */ char *copy_string(); (void) addsym( copy_string( ccltxt ), (char *) 0, cclnum, ccltab, CCL_HASH_SIZE ); }/* ccllookup - lookup the number associated with character class text * * synopsis * char ccltxt[]; * int ccllookup, cclval; * cclval/0 = ccllookup( ccltxt ); */int ccllookup( ccltxt )char ccltxt[]; { return ( findsym( ccltxt, ccltab, CCL_HASH_SIZE )->int_val ); }/* findsym - find symbol in symbol table * * synopsis * char sym[]; * hash_table table; * int table_size; * struct hash_entry *entry, *findsym(); * entry = findsym( sym, table, table_size ); */struct hash_entry *findsym( sym, table, table_size )register char sym[];hash_table table;int table_size; { register struct hash_entry *entry = table[hashfunct( sym, table_size )]; static struct hash_entry empty_entry = { (struct hash_entry *) 0, (struct hash_entry *) 0, NULL, NULL, 0, } ; while ( entry ) { if ( ! strcmp( sym, entry->name ) ) return ( entry ); entry = entry->next; } return ( &empty_entry ); } /* hashfunct - compute the hash value for "str" and hash size "hash_size" * * synopsis * char str[]; * int hash_size, hash_val; * hash_val = hashfunct( str, hash_size ); */int hashfunct( str, e )register char str[];int hash_size; { register int hashval; register int locstr; hashval = 0; locstr = 0; while ( str[locstr] ) hashval = ((hashval << 1) + str[locstr++]) % hash_size; return ( hashval ); }/* ndinstal - install a name definition * * synopsis * char nd[], def[]; * ndinstal( nd, def ); */ndinstal( nd, def )char nd[], def[]; { char *copy_string(); if ( addsym( copy_string( nd ), copy_string( def ), 0, ndtbl, NAME_TABLE_HASH_SIZE ) ) synerr( "name defined twice" ); }/* ndlookup - lookup a name definition * * synopsis * char nd[], *def; * char *ndlookup(); * def/NULL = ndlookup( nd ); */char *ndlookup( nd )char nd[]; { return ( findsym( nd, ndtbl, NAME_TABLE_HASH_SIZE )->str_val ); }/* scinstal - make a start condition * * synopsis * char str[]; * int xcluflg; * scinstal( str, xcluflg ); * * NOTE * the start condition is Exclusive if xcluflg is true */scinstal( str, xcluflg )char str[];int xcluflg; { char *copy_string(); /* bit of a hack. We know how the default start-condition is * declared, and don't put out a define for it, because it * would come out as "#define 0 1" */ /* actually, this is no longer the case. The default start-condition * is now called "INITIAL". But we keep the following for the sake * of future robustness. */ if ( strcmp( str, "0" ) ) printf( "#define %s %d\n", str, lastsc * 2 ); if ( ++lastsc >= current_max_scs ) { current_max_scs += MAX_SCS_INCREMENT; ++num_reallocs; scset = reallocate_integer_array( scset, current_max_scs ); scbol = reallocate_integer_array( scbol, current_max_scs ); scxclu = reallocate_integer_array( scxclu, current_max_scs ); actvsc = reallocate_integer_array( actvsc, current_max_scs ); } if ( addsym( copy_string( str ), (char *) 0, lastsc, sctbl, START_COND_HASH_SIZE ) ) lerrsf( "start condition %s declared twice", str ); scset[lastsc] = mkstate( SYM_EPSILON ); scbol[lastsc] = mkstate( SYM_EPSILON ); scxclu[lastsc] = xcluflg; }/* sclookup - lookup the number associated with a start condition * * synopsis * char str[], scnum; * int sclookup; * scnum/0 = sclookup( str ); */int sclookup( str )char str[]; { return ( findsym( str, sctbl, START_COND_HASH_SIZE )->int_val ); } :MPW:MPW Tools:Tools with Source:Fast LEX:tblcmp.c
/* tblcmp - table compression routines *//* * Copyright (c) 1987, the University of California * * The United States Government has rights in this work pursuant to * contract no. DE-AC03-76SF00098 between the United States Department of * Energy and the University of California. * * This program may be redistributed. Enhancements and derivative works * may be created provided the new works, if made available to the general * public, are made available for use by anyone. */#include "flexdef.h"/* bldtbl - build table entries for dfa state * * synopsis * int state[numecs], statenum, totaltrans, comstate, comfreq; * bldtbl( state, statenum, totaltrans, comstate, comfreq ); * * State is the statenum'th dfa state. It is indexed by equivalence class and * gives the number of the state to enter for a given equivalence class. * totaltrans is the total number of transitions out of the state. Comstate * is that state which is the destination of the most transitions out of State. * Comfreq is how many transitions there are out of State to Comstate. * * A note on terminology: * "protos" are transition tables which have a high probability of * either being redundant (a state processed later will have an identical * transition table) or nearly redundant (a state processed later will have * many of the same out-transitions). A "most recently used" queue of * protos is kept around with the hope that most states will find a proto * which is similar enough to be usable, and therefore compacting the * output tables. * "templates" are a special type of proto. If a transition table is * homogeneous or nearly homogeneous (all transitions go to the same * destination) then the odds are good that future states will also go * to the same destination state on basically the same character set. * These homogeneous states are so common when dealing with large rule * sets that they merit special attention. If the transition table were * simply made into a proto, then (typically) each subsequent, similar * state will differ from the proto for two out-transitions. One of these * out-transitions will be that character on which the proto does not go * to the common destination, and one will be that character on which the * state does not go to the common destination. Templates, on the other * hand, go to the common state on EVERY transition character, and therefore * cost only one difference. */bldtbl( state, statenum, totaltrans, comstate, comfreq )int state[], statenum, totaltrans, comstate, comfreq; { int extptr, extrct[2][CSIZE + 1]; int mindiff, minprot, i, d; int checkcom; /* If extptr is 0 then the first array of extrct holds the result of the * "best difference" to date, which is those transitions which occur in * "state" but not in the proto which, to date, has the fewest differences * between itself and "state". If extptr is 1 then the second array of * extrct hold the best difference. The two arrays are toggled * between so that the best difference to date can be kept around and * also a difference just created by checking against a candidate "best" * proto. */ extptr = 0; /* if the state has too few out-transitions, don't bother trying to * compact its tables */ if ( (totaltrans * 100) < (numecs * PROTO_SIZE_PERCENTAGE) ) mkentry( state, numecs, statenum, JAMSTATE, totaltrans ); else { /* checkcom is true if we should only check "state" against * protos which have the same "comstate" value */ checkcom = comfreq * 100 > totaltrans * CHECK_COM_PERCENTAGE; minprot = firstprot; mindiff = totaltrans; if ( checkcom ) { /* find first proto which has the same "comstate" */ for ( i = firstprot; i != NIL; i = protnext[i] ) if ( protcomst[i] == comstate ) { minprot = i; mindiff = tbldiff( state, minprot, extrct[extptr] ); break; } } else { /* since we've decided that the most common destination out * of "state" does not occur with a high enough frequency, * we set the "comstate" to zero, assuring that if this state * is entered into the proto list, it will not be considered * a template. */ comstate = 0; if ( firstprot != NIL ) { minprot = firstprot; mindiff = tbldiff( state, minprot, extrct[extptr] ); } } /* we now have the first interesting proto in "minprot". If * it matches within the tolerances set for the first proto, * we don't want to bother scanning the rest of the proto list * to see if we have any other reasonable matches. */ if ( mindiff * 100 > totaltrans * FIRST_MATCH_DIFF_PERCENTAGE ) { /* not a good enough match. Scan the rest of the protos */ for ( i = minprot; i != NIL; i = protnext[i] ) { d = tbldiff( state, i, extrct[1 - extptr] ); if ( d < mindiff ) { extptr = 1 - extptr; mindiff = d; minprot = i; } } } /* check if the proto we've decided on as our best bet is close * enough to the state we want to match to be usable */ if ( mindiff * 100 > totaltrans * ACCEPTABLE_DIFF_PERCENTAGE ) { /* no good. If the state is homogeneous enough, we make a * template out of it. Otherwise, we make a proto. */ if ( comfreq * 100 >= totaltrans * TEMPLATE_SAME_PERCENTAGE ) mktemplate( state, statenum, comstate ); else { mkprot( state, statenum, comstate ); mkentry( state, numecs, statenum, JAMSTATE, totaltrans ); } } else { /* use the proto */ mkentry( extrct[extptr], numecs, statenum, prottbl[minprot], mindiff ); /* if this state was sufficiently different from the proto * we built it from, make it, too, a proto */ if ( mindiff * 100 >= totaltrans * NEW_PROTO_DIFF_PERCENTAGE ) mkprot( state, statenum, comstate ); /* since mkprot added a new proto to the proto queue, it's possible * that "minprot" is no longer on the proto queue (if it happened * to have been the last entry, it would have been bumped off). * If it's not there, then the new proto took its physical place * (though logically the new proto is at the beginning of the * queue), so in that case the following call will do nothing. */ mv2front( minprot ); } } }/* cmptmps - compress template table entries * * synopsis * cmptmps(); * * template tables are compressed by using the 'template equivalence * classes', which are collections of transition character equivalence * classes which always appear together in templates - really meta-equivalence * classes. until this point, the tables for templates have been stored * up at the top end of the nxt array; they will now be compressed and have * table entries made for them. */cmptmps() { int tmpstorage[CSIZE + 1]; register int *tmp = tmpstorage, i, j; int totaltrans, trans; peakpairs = numtemps * numecs + tblend; if ( usemecs ) { /* create equivalence classes base on data gathered on template * transitions */ nummecs = cre8ecs( tecfwd, tecbck, numecs ); } else nummecs = numecs; if ( lastdfa + numtemps + 1 >= current_max_dfas ) increase_max_dfas(); /* loop through each template */ for ( i = 1; i <= numtemps; ++i ) { totaltrans = 0; /* number of non-jam transitions out of this template */ for ( j = 1; j <= numecs; ++j ) { trans = tnxt[numecs * i + j]; if ( usemecs ) { /* the absolute value of tecbck is the meta-equivalence class * of a given equivalence class, as set up by cre8ecs */ if ( tecbck[j] > 0 ) { tmp[tecbck[j]] = trans; if ( trans > 0 ) ++totaltrans; } } else { tmp[j] = trans; if ( trans > 0 ) ++totaltrans; } } /* it is assumed (in a rather subtle way) in the skeleton that * if we're using meta-equivalence classes, the def[] entry for * all templates is the jam template, i.e., templates never default * to other non-jam table entries (e.g., another template) */ /* leave room for the jam-state after the last real state */ mkentry( tmp, nummecs, lastdfa + i + 1, JAMSTATE, totaltrans ); } }/* expand_nxt_chk - expand the next check arrays */expand_nxt_chk() { register int old_max = current_max_xpairs; current_max_xpairs += MAX_XPAIRS_INCREMENT; ++num_reallocs; nxt = reallocate_integer_array( nxt, current_max_xpairs ); chk = reallocate_integer_array( chk, current_max_xpairs ); bzero( (char *) (chk + old_max), MAX_XPAIRS_INCREMENT * sizeof( int ) / sizeof( char ) ); }/* find_table_space - finds a space in the table for a state to be placed * * synopsis * int *state, numtrans, block_start; * int find_table_space(); * * block_start = find_table_space( state, numtrans ); * * State is the state to be added to the full speed transition table. * Numtrans is the number of out-transitions for the state. * * find_table_space() returns the position of the start of the first block (in * chk) able to accommodate the state * * In determining if a state will or will not fit, find_table_space() must take * into account the fact that an end-of-buffer state will be added at [0], * and an action number will be added in [-1]. */int find_table_space( state, numtrans )int *state, numtrans; { /* firstfree is the position of the first possible occurrence of two * consecutive unused records in the chk and nxt arrays */ register int i; register int *state_ptr, *chk_ptr; register int *ptr_to_last_entry_in_state; /* if there are too many out-transitions, put the state at the end of * nxt and chk */ if ( numtrans > MAX_XTIONS_FOR_FULL_INTERIOR_FIT ) { /* if table is empty, return the first available spot in chk/nxt, * which should be 1 */ if ( tblend < 2 ) return ( 1 ); i = tblend - numecs; /* start searching for table space near the * end of chk/nxt arrays */ } else i = firstfree; /* start searching for table space from the * beginning (skipping only the elements * which will definitely not hold the new * state) */ while ( 1 ) /* loops until a space is found */ { if ( i + numecs > current_max_xpairs ) expand_nxt_chk(); /* loops until space for end-of-buffer and action number are found */ while ( 1 ) { if ( chk[i - 1] == 0 ) /* check for action number space */ { if ( chk[i] == 0 ) /* check for end-of-buffer space */ break; else i += 2; /* since i != 0, there is no use checking to * see if (++i) - 1 == 0, because that's the * same as i == 0, so we skip a space */ } else ++i; if ( i + numecs > current_max_xpairs ) expand_nxt_chk(); } /* if we started search from the beginning, store the new firstfree for * the next call of find_table_space() */ if ( numtrans <= MAX_XTIONS_FOR_FULL_INTERIOR_FIT ) firstfree = i + 1; /* check to see if all elements in chk (and therefore nxt) that are * needed for the new state have not yet been taken */ state_ptr = &state[1]; ptr_to_last_entry_in_state = &chk[i + numecs + 1]; for ( chk_ptr = &chk[i + 1]; chk_ptr != ptr_to_last_entry_in_state; ++chk_ptr ) if ( *(state_ptr++) != 0 && *chk_ptr != 0 ) break; if ( chk_ptr == ptr_to_last_entry_in_state ) return ( i ); else ++i; } }/* genctbl - generates full speed compressed transition table * * synopsis * genctbl(); */genctbl() { register int i; /* table of verify for transition and offset to next state */ printf( "static struct yy_trans_info yy_transition[%d] =\n", tblend + numecs + 1 ); printf( " {\n" ); /* We want the transition to be represented as the offset to the * next state, not the actual state number, which is what it currently is. * The offset is base[nxt[i]] - base[chk[i]]. That's just the * difference between the starting points of the two involved states * (to - from). * * first, though, we need to find some way to put in our end-of-buffer * flags and states. We do this by making a state with absolutely no * transitions. We put it at the end of the table. */ /* at this point, we're guaranteed that there's enough room in nxt[] * and chk[] to hold tblend + numecs entries. We need just two slots. * One for the action and one for the end-of-buffer transition. We * now *assume* that we're guaranteed the only character we'll try to * index this nxt/chk pair with is EOB, i.e., 0, so we don't have to * make sure there's room for jam entries for other characters. */ base[lastdfa + 1] = tblend + 2; nxt[tblend + 1] = END_OF_BUFFER_ACTION; chk[tblend + 1] = numecs + 1; chk[tblend + 2] = 1; /* anything but EOB */ nxt[tblend + 2] = 0; /* so that "make test" won't show arb. differences */ /* make sure every state has a end-of-buffer transition and an action # */ for ( i = 0; i <= lastdfa; ++i ) { chk[base[i]] = EOB_POSITION; chk[base[i] - 1] = ACTION_POSITION; nxt[base[i] - 1] = dfaacc[i].dfaacc_state; /* action number */ } for ( i = 0; i <= lastsc * 2; ++i ) nxt[base[i] - 1] = DEFAULT_ACTION; dataline = 0; datapos = 0; for ( i = 0; i <= tblend; ++i ) { if ( chk[i] == EOB_POSITION ) transition_struct_out( 0, base[lastdfa + 1] - i ); else if ( chk[i] == ACTION_POSITION ) transition_struct_out( 0, nxt[i] ); else if ( chk[i] > numecs || chk[i] == 0 ) transition_struct_out( 0, 0 ); /* unused slot */ else /* verify, transition */ transition_struct_out( chk[i], base[nxt[i]] - (i - chk[i]) ); } /* here's the final, end-of-buffer state */ transition_struct_out( chk[tblend + 1], nxt[tblend + 1] ); transition_struct_out( chk[tblend + 2], nxt[tblend + 2] ); printf( " };\n" ); printf( "\n" ); /* table of pointers to start states */ printf( "static struct yy_trans_info *yy_state_ptr[%d] =\n", lastsc * 2 + 1 ); printf( " {\n" ); for ( i = 0; i <= lastsc * 2; ++i ) printf( " &yy_transition[%d],\n", base[i] ); printf( " };\n" ); if ( useecs ) genecs(); }/* gentabs - generate data statements for the transition tables * * synopsis * gentabs(); */gentabs() { int i, j, k, *accset, nacc, *acc_array; char clower(); /* *everything* is done in terms of arrays starting at 1, so provide * a null entry for the zero element of all FTL arrays */ static char ftl_long_decl[] = "static long int %c[%d] =\n { 0,\n"; static char ftl_short_decl[] = "static short int %c[%d] =\n { 0,\n"; static char ftl_char_decl[] = "static char %c[%d] =\n { 0,\n"; acc_array = allocate_integer_array( current_max_dfas ); nummt = 0; if ( fulltbl ) jambase = lastdfa + 1; /* home of "jam" pseudo-state */ printf( "#define YY_JAM %d\n", jamstate ); printf( "#define YY_JAM_BASE %d\n", jambase ); if ( usemecs ) printf( "#define YY_TEMPLATE %d\n", lastdfa + 2 ); if ( reject ) { /* write out accepting list and pointer list * first we generate the ACCEPT array. In the process, we compute * the indices that will go into the ALIST array, and save the * indices in the dfaacc array */ printf( accnum > 127 ? ftl_short_decl : ftl_char_decl, ACCEPT, max( numas, 1 ) + 1 ); j = 1; /* index into ACCEPT array */ for ( i = 1; i <= lastdfa; ++i ) { acc_array[i] = j; if ( accsiz[i] != 0 ) { accset = dfaacc[i].dfaacc_set; nacc = accsiz[i]; if ( trace ) fprintf( stderr, "state # %d accepts: ", i ); for ( k = 1; k <= nacc; ++k ) {
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:Fast LEX:tblcmp.c
+++++ Continued from previous card +++++
++j; mkdata( accset[k] ); if ( trace ) { fprintf( stderr, "[%d]", accset[k] ); if ( k < nacc ) fputs( ", ", stderr ); else putc( '\n', stderr ); } } } } /* add accepting number for the "jam" state */ acc_array[i] = j; dataend(); } else { for ( i = 1; i <= lastdfa; ++i ) acc_array[i] = dfaacc[i].dfaacc_state; acc_array[i] = 0; /* add (null) accepting number for jam state */ } /* spit out ALIST array. If we're doing "reject", it'll be pointers * into the ACCEPT array. Otherwise it's actual accepting numbers. * In either case, we just dump the numbers. */ /* "lastdfa + 2" is the size of ALIST; includes room for FTL arrays * beginning at 0 and for "jam" state */ k = lastdfa + 2; if ( reject ) /* we put a "cap" on the table associating lists of accepting * numbers with state numbers. This is needed because we tell * where the end of an accepting list is by looking at where * the list for the next state starts. */ ++k; printf( ((reject && numas > 126) || accnum > 127) ? ftl_short_decl : ftl_char_decl, ALIST, k ); /* set up default actions */ for ( i = 1; i <= lastsc * 2; ++i ) acc_array[i] = DEFAULT_ACTION; acc_array[end_of_buffer_state] = END_OF_BUFFER_ACTION; for ( i = 1; i <= lastdfa; ++i ) { mkdata( acc_array[i] ); if ( ! reject && trace && acc_array[i] ) fprintf( stderr, "state # %d accepts: [%d]\n", i, acc_array[i] ); } /* add entry for "jam" state */ mkdata( acc_array[i] ); if ( reject ) /* add "cap" for the list */ mkdata( acc_array[i] ); dataend(); if ( useecs ) genecs(); if ( usemecs ) { /* write out meta-equivalence classes (used to index templates with) */ if ( trace ) fputs( "\n\nMeta-Equivalence Classes:\n", stderr ); printf( ftl_char_decl, MATCHARRAY, numecs + 1 ); for ( i = 1; i <= numecs; ++i ) { if ( trace ) fprintf( stderr, "%d = %d\n", i, abs( tecbck[i] ) ); mkdata( abs( tecbck[i] ) ); } dataend(); } if ( ! fulltbl ) { int total_states = lastdfa + numtemps; printf( tblend > MAX_SHORT ? ftl_long_decl : ftl_short_decl, BASEARRAY, total_states + 1 ); for ( i = 1; i <= lastdfa; ++i ) { register int d = def[i]; if ( base[i] == JAMSTATE ) base[i] = jambase; if ( d == JAMSTATE ) def[i] = jamstate; else if ( d < 0 ) { /* template reference */ ++tmpuses; def[i] = lastdfa - d + 1; } mkdata( base[i] ); } /* generate jam state's base index */ mkdata( base[i] ); for ( ++i /* skip jam state */; i <= total_states; ++i ) { mkdata( base[i] ); def[i] = jamstate; } dataend(); printf( tblend > MAX_SHORT ? ftl_long_decl : ftl_short_decl, DEFARRAY, total_states + 1 ); for ( i = 1; i <= total_states; ++i ) mkdata( def[i] ); dataend(); printf( lastdfa > MAX_SHORT ? ftl_long_decl : ftl_short_decl, NEXTARRAY, tblend + 1 ); for ( i = 1; i <= tblend; ++i ) { if ( nxt[i] == 0 || chk[i] == 0 ) nxt[i] = jamstate; /* new state is the JAM state */ mkdata( nxt[i] ); } dataend(); printf( lastdfa > MAX_SHORT ? ftl_long_decl : ftl_short_decl, CHECKARRAY, tblend + 1 ); for ( i = 1; i <= tblend; ++i ) { if ( chk[i] == 0 ) ++nummt; mkdata( chk[i] ); } dataend(); } }/* generate equivalence-class tables */genecs() { register int i, j; static char ftl_char_decl[] = "static char %c[%d] =\n { 0,\n"; int numrows; printf( ftl_char_decl, ECARRAY, CSIZE + 1 ); for ( i = 1; i <= CSIZE; ++i ) { if ( caseins && (i >= 'A') && (i <= 'Z') ) ecgroup[i] = ecgroup[clower( i )]; ecgroup[i] = abs( ecgroup[i] ); mkdata( ecgroup[i] ); } dataend(); if ( trace ) { fputs( "\n\nEquivalence Classes:\n\n", stderr ); numrows = (CSIZE + 1) / 8; for ( j = 1; j <= numrows; ++j ) { for ( i = j; i <= CSIZE; i = i + numrows ) { if ( i >= 1 && i <= 31 ) fprintf( stderr, "^%c = %-2d", 'A' + i - 1, ecgroup[i] ); else if ( i >= 32 && i <= 126 ) fprintf( stderr, " %c = %-2d", i, ecgroup[i] ); else if ( i == 127 ) fprintf( stderr, "^@ = %-2d", ecgroup[i] ); else fprintf( stderr, "\nSomething Weird: %d = %d\n", i, ecgroup[i] ); putc( '\t', stderr ); } putc( '\n', stderr ); } } }/* inittbl - initialize transition tables * * synopsis * inittbl(); * * Initializes "firstfree" to be one beyond the end of the table. Initializes * all "chk" entries to be zero. Note that templates are built in their * own tbase/tdef tables. They are shifted down to be contiguous * with the non-template entries during table generation. */inittbl() { register int i; bzero( (char *) chk, current_max_xpairs * sizeof( int ) / sizeof( char ) ); tblend = 0; firstfree = tblend + 1; numtemps = 0; if ( usemecs ) { /* set up doubly-linked meta-equivalence classes * these are sets of equivalence classes which all have identical * transitions out of TEMPLATES */ tecbck[1] = NIL; for ( i = 2; i <= numecs; ++i ) { tecbck[i] = i - 1; tecfwd[i - 1] = i; } tecfwd[numecs] = NIL; } }/* make_tables - generate transition tables * * synopsis * make_tables(); * * Generates transition tables and finishes generating output file */make_tables() { if ( fullspd ) { /* need to define YY_TRANS_OFFSET_TYPE as a size large * enough to hold the biggest offset */ int total_table_size = tblend + numecs + 1; printf( "#define YY_TRANS_OFFSET_TYPE %s\n", total_table_size > MAX_SHORT ? "long" : "short" ); } if ( fullspd || fulltbl ) skelout(); /* compute the tables and copy them to output file */ if ( fullspd ) genctbl(); else gentabs(); skelout(); (void) fclose( temp_action_file ); temp_action_file = fopen( action_file_name, "r" ); /* copy prolog from action_file to output file */ action_out(); skelout(); /* copy actions from action_file to output file */ action_out(); skelout(); /* copy remainder of input to output */ line_directive_out( stdout ); (void) flexscan(); /* copy remainder of input to output */ }/* mkdeftbl - make the default, "jam" table entries * * synopsis * mkdeftbl(); */mkdeftbl() { int i; jamstate = lastdfa + 1; if ( tblend + numecs > current_max_xpairs ) expand_nxt_chk(); for ( i = 1; i <= numecs; ++i ) { nxt[tblend + i] = 0; chk[tblend + i] = jamstate; } jambase = tblend; base[jamstate] = jambase; /* should generate a run-time array bounds check if * ever used as a default */ def[jamstate] = BAD_SUBSCRIPT; tblend += numecs; ++numtemps; }/* mkentry - create base/def and nxt/chk entries for transition array * * synopsis * int state[numchars + 1], numchars, statenum, deflink, totaltrans; * mkentry( state, numchars, statenum, deflink, totaltrans ); * * "state" is a transition array "numchars" characters in size, "statenum" * is the offset to be used into the base/def tables, and "deflink" is the * entry to put in the "def" table entry. If "deflink" is equal to * "JAMSTATE", then no attempt will be made to fit zero entries of "state" * (i.e., jam entries) into the table. It is assumed that by linking to * "JAMSTATE" they will be taken care of. In any case, entries in "state" * marking transitions to "SAME_TRANS" are treated as though they will be * taken care of by whereever "deflink" points. "totaltrans" is the total * number of transitions out of the state. If it is below a certain threshold, * the tables are searched for an interior spot that will accommodate the * state array. */mkentry( state, numchars, statenum, deflink, totaltrans )register int *state;int numchars, statenum, deflink, totaltrans; { register int minec, maxec, i, baseaddr; int tblbase, tbllast; if ( totaltrans == 0 ) { /* there are no out-transitions */ if ( deflink == JAMSTATE ) base[statenum] = JAMSTATE; else base[statenum] = 0; def[statenum] = deflink; return; } for ( minec = 1; minec <= numchars; ++minec ) { if ( state[minec] != SAME_TRANS ) if ( state[minec] != 0 || deflink != JAMSTATE ) break; } if ( totaltrans == 1 ) { /* there's only one out-transition. Save it for later to fill * in holes in the tables. */ stack1( statenum, minec, state[minec], deflink ); return; } for ( maxec = numchars; maxec > 0; --maxec ) { if ( state[maxec] != SAME_TRANS ) if ( state[maxec] != 0 || deflink != JAMSTATE ) break; } /* Whether we try to fit the state table in the middle of the table * entries we have already generated, or if we just take the state * table at the end of the nxt/chk tables, we must make sure that we * have a valid base address (i.e., non-negative). Note that not only are * negative base addresses dangerous at run-time (because indexing the * next array with one and a low-valued character might generate an * array-out-of-bounds error message), but at compile-time negative * base addresses denote TEMPLATES. */ /* find the first transition of state that we need to worry about. */ if ( totaltrans * 100 <= numchars * INTERIOR_FIT_PERCENTAGE ) { /* attempt to squeeze it into the middle of the tabls */ baseaddr = firstfree; while ( baseaddr < minec ) { /* using baseaddr would result in a negative base address below * find the next free slot */ for ( ++baseaddr; chk[baseaddr] != 0; ++baseaddr ) ; } if ( baseaddr + maxec - minec >= current_max_xpairs ) expand_nxt_chk(); for ( i = minec; i <= maxec; ++i ) if ( state[i] != SAME_TRANS ) if ( state[i] != 0 || deflink != JAMSTATE ) if ( chk[baseaddr + i - minec] != 0 ) { /* baseaddr unsuitable - find another */ for ( ++baseaddr; baseaddr < current_max_xpairs && chk[baseaddr] != 0; ++baseaddr ) ; if ( baseaddr + maxec - minec >= current_max_xpairs ) expand_nxt_chk(); /* reset the loop counter so we'll start all * over again next time it's incremented */ i = minec - 1; } } else { /* ensure that the base address we eventually generate is * non-negative */ baseaddr = max( tblend + 1, minec ); } tblbase = baseaddr - minec; tbllast = tblbase + maxec; if ( tbllast >= current_max_xpairs ) expand_nxt_chk(); base[statenum] = tblbase; def[statenum] = deflink; for ( i = minec; i <= maxec; ++i ) if ( state[i] != SAME_TRANS ) if ( state[i] != 0 || deflink != JAMSTATE ) { nxt[tblbase + i] = state[i]; chk[tblbase + i] = statenum; } if ( baseaddr == firstfree ) next free slot in tables */ for ( ++firstfree; chk[firstfree] != 0; ++firstfree ) ; tblend = max( tblend, tbllast ); }/* mk1tbl - create table entries for a state (or state fragment) which * has only one out-transition * * synopsis * int state, sym, onenxt, onedef; * mk1tbl( state, sym, onenxt, onedef ); */mk1tbl( state, sym, onenxt, onedef )int state, sym, onenxt, onedef; { if ( firstfree < sym ) firstfree = sym; while ( chk[firstfree] != 0 ) if ( ++firstfree >= current_max_xpairs ) expand_nxt_chk(); base[state] = firstfree - sym; def[state] = onedef; chk[firstfree] = state; nxt[firstfree] = onenxt; if ( firstfree > tblend ) { tblend = firstfree++; if ( firstfree >= current_max_xpairs ) expand_nxt_chk(); } }/* mkprot - create new proto entry * * synopsis * int state[], statenum, comstate; * mkprot( state, statenum, comstate ); */mkprot( state, statenum, comstate )int state[], statenum, comstate; { int i, slot, tblbase; if ( ++numprots >= MSP || numecs * numprots >= PROT_SAVE_SIZE ) { /* gotta make room for the new proto by dropping last entry in * the queue */ slot = lastprot; lastprot = protprev[lastprot]; protnext[lastprot] = NIL; } else slot = numprots; protnext[slot] = firstprot; if ( firstprot != NIL ) protprev[firstprot] = slot; firstprot = slot; prottbl[slot] = statenum; protcomst[slot] = comstate; /* copy state into save area so it can be compared with rapidly */ tblbase = numecs * (slot - 1); for ( i = 1; i <= numecs; ++i ) protsave[tblbase + i] = state[i]; }/* mktemplate - create a template entry based on a state, and connect the state * to it * * synopsis * int state[], statenum, comstate, totaltrans; * mktemplate( state, statenum, comstate, totaltrans ); */mktemplate( state, statenum, comstate )int state[], statenum, comstate; { int i, numdiff, tmpbase, tmp[CSIZE + 1]; char transset[CSIZE + 1]; int tsptr; ++numtemps; tsptr = 0; /* calculate where we will temporarily store the transition table * of the template in the tnxt[] array. The final transition table * gets created by cmptmps() */ tmpbase = numtemps * numecs; if ( tmpbase + numecs >= current_max_template_xpairs ) { current_max_template_xpairs += MAX_TEMPLATE_XPAIRS_INCREMENT; ++num_reallocs; tnxt = reallocate_integer_array( tnxt, current_max_template_xpairs ); } for ( i = 1; i <= numecs; ++i ) if ( state[i] == 0 ) tnxt[tmpbase + i] = 0; else { transset[tsptr++] = i; tnxt[tmpbase + i] = comstate; } if ( usemecs ) mkeccl( transset, tsptr, tecfwd, tecbck, numecs ); mkprot( tnxt + tmpbase, -numtemps, comstate ); /* we rely on the fact that mkprot adds things to the beginning * of the proto queue */ numdiff = tbldiff( state, firstprot, tmp ); mkentry( tmp, numecs, statenum, -numtemps, numdiff ); }/* mv2front - move proto queue element to front of queue * * synopsis * int qelm; * mv2front( qelm ); */mv2front( qelm )int qelm; { if ( firstprot != qelm ) { if ( qelm == lastprot ) lastprot = protprev[lastprot]; protnext[protprev[qelm]] = protnext[qelm]; if ( protnext[qelm] != NIL ) protprev[protnext[qelm]] = protprev[qelm]; protprev[qelm] = NIL; protnext[qelm] = firstprot; protprev[firstprot] = qelm; firstprot = qelm; } }/* ntod - convert an ndfa to a dfa * * synopsis * ntod(); * * creates the dfa corresponding to the ndfa we've constructed. the * dfa starts out in state #1. */ntod() { int *accset, ds, nacc, newds; int duplist[CSIZE + 1], sym, hashval, numstates, dsize; int targfreq[CSIZE + 1], targstate[CSIZE + 1], state[CSIZE + 1]; int *nset, *dset; int targptr, totaltrans, i, comstate, comfreq, targ; int *epsclosure(), snstods(), symlist[CSIZE + 1]; /* this is so find_table_space(...) will know where to start looking in * chk/nxt for unused records for space to put in the state */ if ( fullspd ) firstfree = 0; accset = allocate_integer_array( accnum + 1 ); nset = allocate_integer_array( current_max_dfa_size ); todo_head = todo_next = 0;#define ADD_QUEUE_ELEMENT(element) \ if ( ++element >= current_max_dfas ) \ { /* check for queue overflowing */ \ if ( todo_head == 0 ) \ increase_max_dfas(); \ else \ element = 0; \ }#define NEXT_QUEUE_ELEMENT(element) ((element + 1) % (current_max_dfas + 1)) for ( i = 0; i <= CSIZE; ++i ) { duplist[i] = NIL; symlist[i] = false; } for ( i = 0; i <= accnum; ++i ) accset[i] = NIL; if ( trace ) { dumpnfa( scset[1] ); fputs( "\n\nDFA Dump:\n\n", stderr ); } inittbl(); if ( fullspd ) { for ( i = 0; i <= numecs; ++i )
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:Fast LEX:tblcmp.c
+++++ Continued from previous card +++++
state[i] = 0; place_state( state, 0, 0 ); } if ( fulltbl ) { /* declare it "short" because it's a real long-shot that that * won't be large enough */ printf( "static short int %c[][%d] =\n {\n", NEXTARRAY, numecs + 1 ); /* '}' so vi doesn't get too confused */ /* generate 0 entries for state #0 */ for ( i = 0; i <= numecs; ++i ) mk2data( 0 ); /* force ',' and dataflush() next call to mk2data */ datapos = NUMDATAITEMS; /* force extra blank line next dataflush() */ dataline = NUMDATALINES; } /* create the first states */ for ( i = 1; i <= lastsc * 2; ++i ) { numstates = 1; /* for each start condition, make one state for the case when * we're at the beginning of the line (the '%' operator) and * one for the case when we're not */ if ( i % 2 == 1 ) nset[numstates] = scset[(i / 2) + 1]; else nset[numstates] = mkbranch( scbol[i / 2], scset[i / 2] ); nset = epsclosure( nset, &numstates, accset, &nacc, &hashval ); if ( snstods( nset, numstates, accset, nacc, hashval, &ds ) ) { numas = numas + nacc; totnst = totnst + numstates; todo[todo_next] = ds; ADD_QUEUE_ELEMENT(todo_next); } } if ( fulltbl ) { if ( ! snstods( nset, 0, accset, 0, 0, &end_of_buffer_state ) ) flexfatal( "could not create unique end-of-buffer state" ); numas += 1; todo[todo_next] = end_of_buffer_state; ADD_QUEUE_ELEMENT(todo_next); } while ( todo_head != todo_next ) { targptr = 0; totaltrans = 0; for ( i = 1; i <= numecs; ++i ) state[i] = 0; ds = todo[todo_head]; todo_head = NEXT_QUEUE_ELEMENT(todo_head); dset = dss[ds]; dsize = dfasiz[ds]; if ( trace ) fprintf( stderr, "state # %d:\n", ds ); sympartition( dset, dsize, symlist, duplist ); for ( sym = 1; sym <= numecs; ++sym ) { if ( symlist[sym] ) { symlist[sym] = 0; if ( duplist[sym] == NIL ) { /* symbol has unique out-transitions */ numstates = symfollowset( dset, dsize, sym, nset ); nset = epsclosure( nset, &numstates, accset, &nacc, &hashval ); if ( snstods( nset, numstates, accset, nacc, hashval, &newds ) ) { totnst = totnst + numstates; todo[todo_next] = newds; ADD_QUEUE_ELEMENT(todo_next); numas = numas + nacc; } state[sym] = newds; if ( trace ) fprintf( stderr, "\t%d\t%d\n", sym, newds ); targfreq[++targptr] = 1; targstate[targptr] = newds; ++numuniq; } else { /* sym's equivalence class has the same transitions * as duplist(sym)'s equivalence class */ targ = state[duplist[sym]]; state[sym] = targ; if ( trace ) fprintf( stderr, "\t%d\t%d\n", sym, targ ); /* update frequency count for destination state */ i = 0; while ( targstate[++i] != targ ) ; ++targfreq[i]; ++numdup; } ++totaltrans; duplist[sym] = NIL; } } numsnpairs = numsnpairs + totaltrans; if ( caseins && ! useecs ) { register int j; for ( i = 'A', j = 'a'; i <= 'Z'; ++i, ++j ) state[i] = state[j]; } if ( fulltbl ) { /* supply array's 0-element */ if ( ds == end_of_buffer_state ) mk2data( 0 ); else mk2data( end_of_buffer_state ); for ( i = 1; i <= numecs; ++i ) mk2data( state[i] ); /* force ',' and dataflush() next call to mk2data */ datapos = NUMDATAITEMS; /* force extra blank line next dataflush() */ dataline = NUMDATALINES; } else if ( fullspd ) place_state( state, ds, totaltrans ); else { /* determine which destination state is the most common, and * how many transitions to it there are */ comfreq = 0; comstate = 0; for ( i = 1; i <= targptr; ++i ) if ( targfreq[i] > comfreq ) { comfreq = targfreq[i]; comstate = targstate[i]; } bldtbl( state, ds, totaltrans, comstate, comfreq ); } } if ( fulltbl ) dataend(); else { cmptmps(); /* create compressed template entries */ /* create tables for all the states with only one out-transition */ while ( onesp > 0 ) { mk1tbl( onestate[onesp], onesym[onesp], onenext[onesp], onedef[onesp] ); --onesp; } mkdeftbl(); } }/* place_state - place a state into full speed transition table * * synopsis * int *state, statenum, transnum; * place_state( state, statenum, transnum ); * * State is the statenum'th state. It is indexed by equivalence class and * gives the number of the state to enter for a given equivalence class. * Transnum is the number of out-transitions for the state. */place_state( state, statenum, transnum )int *state, statenum, transnum; { register int i; register int *state_ptr; int position = find_table_space( state, transnum ); /* base is the table of start positions */ base[statenum] = position; /* put in action number marker; this non-zero number makes sure that * find_table_space() knows that this position in chk/nxt is taken * and should not be used for another accepting number in another state */ chk[position - 1] = 1; /* put in end-of-buffer marker; this is for the same purposes as above */ chk[position] = 1; /* place the state into chk and nxt */ state_ptr = &state[1]; for ( i = 1; i <= numecs; ++i, ++state_ptr ) if ( *state_ptr != 0 ) { chk[position + i] = i; nxt[position + i] = *state_ptr; } if ( position + numecs > tblend ) tblend = position + numecs; }/* stack1 - save states with only one out-transition to be processed later * * synopsis * int statenum, sym, nextstate, deflink; * stack1( statenum, sym, nextstate, deflink ); * * if there's room for another state one the "one-transition" stack, the * state is pushed onto it, to be processed later by mk1tbl. If there's * no room, we process the sucker right now. */stack1( statenum, sym, nextstate, deflink )int statenum, sym, nextstate, deflink; { if ( onesp >= ONE_STACK_SIZE ) mk1tbl( statenum, sym, nextstate, deflink ); else { ++onesp; onestate[onesp] = statenum; onesym[onesp] = sym; onenext[onesp] = nextstate; onedef[onesp] = deflink; } }/* tbldiff - compute differences between two state tables * * synopsis * int state[], pr, ext[]; * int tbldiff, numdifferences; * numdifferences = tbldiff( state, pr, ext ) * * "state" is the state array which is to be extracted from the pr'th * proto. "pr" is both the number of the proto we are extracting from * and an index into the save area where we can find the proto's complete * state table. Each entry in "state" which differs from the corresponding * entry of "pr" will appear in "ext". * Entries which are the same in both "state" and "pr" will be marked * as transitions to "SAME_TRANS" in "ext". The total number of differences * between "state" and "pr" is returned as function value. Note that this * number is "numecs" minus the number of "SAME_TRANS" entries in "ext". */int tbldiff( state, pr, ext )int state[], pr, ext[]; { register int i, *sp = state, *ep = ext, *protp; register int numdiff = 0; protp = &protsave[numecs * (pr - 1)]; for ( i = numecs; i > 0; --i ) { if ( *++protp == *++sp ) *++ep = SAME_TRANS; else { *++ep = *sp; ++numdiff; } } return ( numdiff ); } :MPW:MPW Tools:Tools with Source:Fast LEX:yylex.c
/* yylex - scanner front-end for flex */#include "flexdef.h"#include "parse.h"/* * Copyright (c) 1987, the University of California * * The United States Government has rights in this work pursuant to * contract no. DE-AC03-76SF00098 between the United States Department of * Energy and the University of California. * * This program may be redistributed. Enhancements and derivative works * may be created provided the new works, if made available to the general * public, are made available for use by anyone. *//* yylex - scan for a regular expression token * * synopsis * * token = yylex(); * * token - return token found */int yylex() { int toktype; static int beglin = false; if ( eofseen ) toktype = EOF; else toktype = flexscan(); if ( toktype == EOF ) { eofseen = 1; if ( sectnum == 1 ) { synerr( "unexpected EOF" ); sectnum = 2; toktype = SECTEND; } else if ( sectnum == 2 ) { sectnum = 3; toktype = SECTEND; } else toktype = 0; } if ( trace ) { if ( beglin ) { fprintf( stderr, "%d\t", accnum + 1 ); beglin = 0; } switch ( toktype ) { case '<': case '>': case '^': case '$': case '"': case '[': case ']': case '{': case '}': case '|': case '(': case ')': case '-': case '/': case '\\': case '?': case '.': case '*': case '+': case ',': (void) putc( toktype, stderr ); break; case '\n': (void) putc( '\n', stderr ); if ( sectnum == 2 ) beglin = 1; break; case SCDECL: fputs( "%s", stderr ); break; case XSCDECL: fputs( "%x", stderr ); break; case WHITESPACE: (void) putc( ' ', stderr ); break; case SECTEND: fputs( "%%\n", stderr ); /* we set beglin to be true so we'll start * writing out numbers as we echo rules. flexscan() has * already assigned sectnum */ if ( sectnum == 2 ) beglin = 1; break; case NAME: fprintf( stderr, "'%s'", nmstr ); break; case CHAR: switch ( yylval ) { case '<': case '>': case '^': case '$': case '"': case '[': case ']': case '{': case '}': case '|': case '(': case ')': case '-': case '/': case '\\': case '?': case '.': case '*': case '+': case ',': fprintf( stderr, "\\%c", yylval ); break; case 1: case 2: case 3: case 4: case 5: case 6: case 7: case 8: case 9: case 10: case 11: case 12: case 13: case 14: case 15: case 16: case 17: case 18: case 19: case 20: case 21: case 22: case 23: case 24: case 25: case 26: case 27: case 28: case 29: case 30: case 31: fprintf( stderr, "^%c", 'A' + yylval - 1 ); break; case 127: (void) putc( '^', stderr ); (void) putc( '@', stderr ); break; default: (void) putc( yylval, stderr ); break; } break; case NUMBER: fprintf( stderr, "%d", yylval ); break; case PREVCCL: fprintf( stderr, "[%d]", yylval ); break; case 0: fprintf( stderr, "End Marker" ); break; default: fprintf( stderr, "*Something Weird* - tok: %d val: %d\n", toktype, yylval ); break; } } return ( toktype ); } :MPW:MPW Tools:Tools with Source:Fdump:FDump.c
/*---------------------------------------------------------------------------* * ProgName : Fdump.C * Descrip : Dumps a file in hex/ASCII to screen, variable record sizes and * start/end records supported. * Version : 1.3 * Language : APW C * Author : Eduard Schwan * Revisions: 3/04/86 - E Schwan - Wrote in Aztec C * 2/10/87 - E Schwan - Compiled it under AppleIIgs APW C. * 8/11/87 - E Schwan - Added APW C wildcard filename support * 11/23/87 - E Schwan - Added ability to use hex numbers * 4/16/88 - E Schwan - Ported to MPW C on the Macintosh *---------------------------------------------------------------------------*/#include <stdio.h>#include <ctype.h>#ifdef AppleIIgs#include <shell.h> /* for STOP() & Wildcards */#endif#ifndef tolower#define tolower(c) (c>='A'&&c<='Z'?c+32:c)#endif#define APPLE_II 1 /* Apple II series specific code */#define LEAD_ZEROES 1 /* leave lead zeroes on hex digits */#define true 1#define false 0#define ofs_fld_size 6#define hex_fld_size 3#define ascii_fld_size 1#define bytes_per_line 16#define line_size (ofs_fld_size+2+\ bytes_per_line*(hex_fld_size+ascii_fld_size))/* to enable debug messages, uncomment the do_debug define *//*#define do_debug /* flag for enabling debugs.. */#ifdef do_debug#define debug(x) x#else#define debug(x)#endiftypedef unsigned char uchar;typedef uchar boolean;typedef unsigned short pos_int;extern int errno;static boolean absolute = false;static pos_int rec_begin = 0;static pos_int rec_end = -1; /* infinite */static pos_int rec_size = 128;static char hex_digits[] = "0123456789abcdef";static pos_int byte_count, hex_ofs, ascii_ofs;static long offset;static char line[line_size+2];#ifdef APPLE_IIboolean keypressed(){ return (*(char*)0xc000 > 127);}#endif#ifdef APPLE_II/* getchar() isn't used only because APW's getchar waits for CR */char rdchar(){char ch; ch = (*(char*)0xc000) & 0x7f; *(char*)0xc010 = 1; /* strobe kb to remove char */ return (ch);}#endifboolean user_quits(){boolean quit; quit = false;#ifdef AppleIIgs quit = STOP(); /* APW Shell call */ if (!quit && keypressed()) { /* get key pressed.. */ if (rdchar() == 27) quit = 1; /* ..and wait for another before continuing */ while (!keypressed() && !quit) { } if (!quit) if (rdchar() == 27) quit = 1; }#endif return( quit );}void htoa(hex_num, width, ptr)long hex_num;pos_int width;char ptr[];{ do { width--; ptr[width] = hex_digits[hex_num % 16]; hex_num = hex_num / 16;#ifdef LEAD_ZEROES } while (width);#else } while (width && hex_num);#endif} /* htoa() */pos_int atoh(hex_str)uchar * hex_str;{pos_int digit;pos_int hex_val;hex_val = 0;while (*hex_str) { digit = tolower(*hex_str); if (digit != '$') { if (digit >= '0' && digit <= '9') { digit = digit & 0x0f; } else if (digit >= 'a' && digit <= 'f') { digit = (digit-8) & 0x0f; } else { /* non-hex character, end */ break; } hex_val = digit + (hex_val<<4); } hex_str++; } /* while */} /* atoh() */static void init_line(){ for (byte_count=0; byte_count<line_size; byte_count++) line[byte_count] = ' '; line[line_size] = 0; htoa(offset, ofs_fld_size, line); hex_ofs = ofs_fld_size + 1; ascii_ofs = hex_ofs + bytes_per_line*hex_fld_size + 2; line[hex_ofs-1] = ':'; line[ascii_ofs-1] = '|'; byte_count = 0;debug(printf("init_line:'%s'\n",line);)} /* init_line() */void write_line(){ puts(line);} /* write_line() */void add_to_line(ch)uchar ch;{ if (byte_count >= bytes_per_line) { write_line(); init_line(); } htoa((long)ch, hex_fld_size-1, &line[hex_ofs]); if (ch>=32 && ch<=127) line[ascii_ofs] = ch; else line[ascii_ofs] = '.'; hex_ofs += hex_fld_size; ascii_ofs += ascii_fld_size; byte_count++; offset++; if (user_quits()) exit (0);} /* add_to_line() */void dump_record(fp, fname, rec_num)FILE* fp;uchar* fname;pos_int rec_num;{uchar ch;pos_int bytes_in_rec;debug(printf("dump_record #%d, feof(%lx)=%d\n",rec_num,fp,feof(fp));) init_line(); bytes_in_rec = 0; while (!feof(fp) && bytes_in_rec < rec_size) { ch = getc(fp);debug(printf("dump_record: got ch $%02x, feof()=%d\n", ch, feof(fp));) if (errno) { fprintf(stderr, "Error $%x reading record %u in file '%s'\n", errno, rec_num, fname); exit(1); } else if (!feof(fp)) { add_to_line(ch); bytes_in_rec++; } } /*while*/ if (byte_count > 0) /* dump any partial line */ write_line();} /* dump_record() */void dump_records(fp, fname)FILE* fp;uchar* fname;{pos_int rec_num; rec_num = rec_begin; while (!feof(fp) && (rec_num<=rec_end)) { printf("\nRecord $%04x/%u\n",rec_num,rec_num); if (absolute) offset = rec_num * rec_size; else offset = 0; dump_record(fp, fname, rec_num); rec_num++; } /*while*/} /* dump_records() */void dump_file(fname)uchar* fname;{FILE* fp;FILE* fopen();debug(printf("dumpfile:a=%d b=%d e=%d s=%d\n",\absolute,rec_begin,rec_end,rec_size);) fp = fopen(fname, "rb"); if (fp == NULL) { fprintf(stderr, "Error $%x opening file '%s'\n", errno, fname); exit(1); } else { if (rec_begin > 0) {debug(printf("dump_file:seek to byte=%d\n",rec_begin*rec_size);) fseek(fp, (long)rec_begin*rec_size, 0); if (errno) { fprintf(stderr, "Error $%x seeking rec. %d in file '%s'\n", errno, rec_begin, fname); exit(1); } } printf("\nFILE : %s\n", fname); dump_records(fp, fname); fclose(fp); }} /* dump_file() */void usage(err)uchar* err;{ fprintf(stderr, "\nError! %s\n", err); fprintf(stderr, "fdump [-a] [-b [$]NN] [-e [$]NN] [-s [$]NN] filename [filenames]\n"); fprintf(stderr, " -a = make offset absolute from beginning of file\n"); fprintf(stderr, " -b NN = begin dump at record NN (NN = 0..eof)\n"); fprintf(stderr, " -e NN = end dump at record NN (NN = 0..eof)\n"); fprintf(stderr, " -s NN = set record size to NN bytes\n"); fprintf(stderr, "NOTE: NN is decimal, $NN is hex\n"); exit(1);} /* usage() */main(argc, argv)int argc;uchar** argv;{uchar* argptr;boolean quit;#ifdef AppleIIgsuchar wild_fname[64];#endif fprintf(stderr, "Fdump Utility 1.3 [esp]\n\n"); if (argc == 1) usage("No Parameters"); while (*++argv) { argptr = *argv;debug(printf("argptr='%s'\n",argptr);) if (*argptr == '-') { /* handle flags */ while (*++argptr) { switch (tolower(*argptr)) { case 'a': absolute = true; break; case 'b': if (++argv) { if (**argv == '$') rec_begin = atoh(*argv); else rec_begin = atoi(*argv); } else usage("Expected number after -b option"); break; case 'e': if (++argv) { if (**argv == '$') rec_end = atoh(*argv); else rec_end = atoi(*argv); } else usage("Expected number after -e option"); break; case 's': if (++argv) { if (**argv == '$') rec_size = atoh(*argv); else rec_size = atoi(*argv); } else usage("Expected number after -s option"); break; default: usage("Unknown option"); } /*switch*/ } /*while*/ } /*handle flags */ else {#ifdef AppleIIgs init_wildcard(argptr); while (next_wildcard(wild_fname)) dump_file(wild_fname);#else dump_file(argptr);#endif } } /*while*/} /* main() */ :MPW:MPW Tools:Tools with Source:Fdump:FDump.Help
FDUMP is a utility that dumps any file to stdout in the following format:FILE : fdumpRecord $0000/0000000:46 44 55 4d 50 20 69 73 20 61 20 75 74 69 6c 69 |FDUMP is a utili000010:74 79 20 74 68 61 74 20 64 75 6d 70 73 20 61 6e |ty that dumps an000020:79 20 6b 69 6e 64 20 6f 66 20 66 69 6c 65 20 74 |y kind of file t000030:6f 20 73 74 64 6f 75 74 20 69 6e 20 74 68 65 20 |o stdout in the000040:66 6f 6c 6c 6f 77 69 6e 67 0d 66 6f 72 6d 61 74 |following.format000050:3a 0d 0d 50 61 72 61 6d 65 74 65 72 73 20 61 72 |:..Parameters ar000060:65 3a 20 28 5b 5d 20 6d 65 61 6e 73 20 6f 70 74 |e: ([] means opt000070:69 6f 6e 61 6c 29 0d 66 64 75 6d 70 20 5b 2d 61 |ional).fdump [-aRecord $0001/1000000:5d 20 5b 2d 62 20 4e 4e 5d 20 5b 2d 65 20 4e 4e |] [-b NN] [-e NN:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::etc..While dumping, the output can be temporarily held by pressing any key, andresumed by pressing any key again. Pressing <ESC> or <APPLE>-<.> aborts.Parameters are: ([] means optional)fdump [-a] [-b NN] [-e NN] [-s NN] filename [filenames] -a = make offset absolute from beginning of file -b NN = begin dump at record NN (NN = 0..eof) -e NN = end dump at record NN (NN = 0..eof) -s NN = set record size to NN bytes :MPW:MPW Tools:Tools with Source:Fdump:FDump.make
;;;; Alloca() for Macintosh Programmer's Workshop C 2.0.2.;; alloca(n) allocates n bytes of storage in the stack;; frame of the caller.;;;; Allows caller to save up to 12 registers on the stack;; at caller's procedure entry, and pop them off on exit.;;;; Calling routine must be set up to align stack pointer between;; calls to functions, or this will fail.;;;; Earle R. Horton Sunday, January 1, 1989;; CASE ON macro BlockMove dc.w $A02E endmSAVESIZE EQU 48 ; 12 registers times 4 bytes each_alloca PROC EXPORT link a6,#0 export allocaalloca move.l (sp)+,a1 ; pop return address move.l (sp)+,d0 ; pop parameter = size in bytes move.l sp,a0 ; save stack pointer, source parameter for BlockMove addq.l #3,d0 ; round size up to long word andi.l #-4,d0 ; mask out lower two bits of size addi.l #SAVESIZE,d0 ; allow for up to 12 registers saved by caller sub.l d0,sp ; allocate by moving stack pointer move.l a1,-(sp) ; push return address lea 4(sp),a1 ; new save reg area, destination pointer for BlockMove move.l #SAVESIZE,d0 ; bytes to move BlockMove ; move save area move.l (sp)+,a0 ; pop return address move.l sp,d0 ; stack pointer to d0 addi.l #SAVESIZE,d0 ; return pointer to just above new save area adda.w #-4,sp ; new top of stack jmp (a0) ; return to caller unlk a6 rts STRING ASIS dc.b 'ALLOCA ' ENDP END :MPW:MPW Tools:Tools with Source:flex ƒ:alloca.s
;;;; Alloca() for Aztec C v 3.6c.;; alloca(n) allocates n bytes of storage in the stack;; frame of the caller.;;;; Allows caller to save up to 12 registers on the stack;; at caller's procedure entry, and pop them off on exit.;;;; Calling routine must be set up to align stack pointer between;; calls to functions, or this will fail.;;;; Earle R. Horton Sunday, January 1, 1989;; macro BlockMove dc.w $A02EendmSAVESIZE EQU 48 ; 12 registers times 4 bytes each link a6,#0 ; So this procedure can have a label. public _alloca_alloca: move.l (sp)+,a1 ; pop return address clr.l d0 ; clear register move.w (sp)+,d0 ; pop parameter = size in bytes move.l sp,a0 ; save stack pointer, source parameter for BlockMove addq.l #3,d0 ; round size up to long word andi.l #-4,d0 ; mask out lower two bits of size addi.l #SAVESIZE,d0 ; allow for up to 12 registers saved by caller sub.l d0,sp ; allocate by moving stack pointer move.l a1,-(sp) ; push return address lea 4( new save reg area, destination pointer for BlockMove move.l #SAVESIZE,d0 ; bytes to move BlockMove ; move save area move.l (sp)+,a0 ; pop return address move.l sp,d0 ; stack pointer to d0 addi.l #SAVESIZE,d0 ; return pointer to just above new save area adda.w #-2,sp ; new stack pointer jmp (a0) ; return to caller unlk a6 rts dc.b 'ALLOCA ' ; Macsbug Label :MPW:MPW Tools:Tools with Source:flex ƒ:allocate.c
/* Allocate and clear storage for bison, Copyright (C) 1984 Bob Corbett and Free Software Foundation, Inc.BISON is distributed in the hope that it will be useful, but WITHOUT ANYWARRANTY. No author or distributor accepts responsibility to anyonefor the consequences of using it or for whether it serves anyparticular purpose or works at all, unless he says so in writing.Refer to the BISON General Public License for full details.Everyone is granted permission to copy, modify and redistribute BISON,but only under the conditions described in the BISON General PublicLicense. A copy of this license is supposed to have been given to youalong with BISON so you can know your rights and responsibilities. Itshould be in a file named COPYING. Among other things, the copyrightnotice and this notice must be preserved on all copies. In other words, you are welcome to use, share and improve this program. You are forbidden to forbid anyone else to use, share and improve what you give them. Help stamp out software-hoarding! */#include <stdio.h>char *allocate(n)register unsigned n;{ register char *block; extern char *calloc(); block = calloc(n,1); if (block == NULL) { fprintf(stderr, "bison: memory exhausted\n"); done(1); } return (block);} :MPW:MPW Tools:Tools with Source:flex ƒ:bzero.c
bzero(x,size)char *x;int size;{ int i; for(i=0;i<size;i++){ *(x+i) = 0; }} :MPW:MPW Tools:Tools with Source:flex ƒ:ccl.c
/* ccl - routines for character classes *//* * Copyright (c) 1987, the University of California * * The United States Government has rights in this work pursuant to * contract no. DE-AC03-76SF00098 between the United States Department of * Energy and the University of California. * * This program may be redistributed. Enhancements and derivative works * may be created provided the new works, if made available to the general * public, are made available for use by anyone. */#include "flexdef.h"/* ccladd - add a single character to a ccl * * synopsis * int cclp; * char ch; * ccladd( cclp, ch ); */ccladd( cclp, ch )int cclp;char ch; { int ind, len, newpos, i; len = ccllen[cclp]; ind = cclmap[cclp]; /* check to see if the character is already in the ccl */ for ( i = 0; i < len; ++i ) if ( ccltbl[ind + i] == ch ) return; newpos = ind + len; if ( newpos >= current_max_ccl_tbl_size ) { current_max_ccl_tbl_size += MAX_CCL_TBL_SIZE_INCREMENT; ++num_reallocs; ccltbl = reallocate_character_array( ccltbl, current_max_ccl_tbl_size ); } ccllen[cclp] = len + 1; ccltbl[newpos] = ch; }/* cclinit - make an empty ccl * * synopsis * int cclinit(); * new_ccl = cclinit(); */int cclinit() { if ( ++lastccl >= current_maxccls ) { current_maxccls += MAXCCLS_INCREMENT; ++num_reallocs; cclmap = reallocate_integer_array( cclmap, current_maxccls ); ccllen = reallocate_integer_array( ccllen, current_maxccls ); cclng = reallocate_integer_array( cclng, current_maxccls ); } if ( lastccl == 1 ) /* we're making the first ccl */ cclmap[lastccl] = 0; else /* the new pointer is just past the end of the last ccl. Since * the cclmap points to the \first/ character of a ccl, adding the * length of the ccl to the cclmap pointer will produce a cursor * to the first free space */ cclmap[lastccl] = cclmap[lastccl - 1] + ccllen[lastccl - 1]; ccllen[lastccl] = 0; cclng[lastccl] = 0; /* ccl's start out life un-negated */ return ( lastccl ); }/* cclnegate - negate a ccl * * synopsis * int cclp; * cclnegate( ccl ); */cclnegate( cclp )int cclp; { cclng[cclp] = 1; } :MPW:MPW Tools:Tools with Source:flex ƒ:Changes
Changes between beta-test release of Feb. '88 and initial release: - many files renamed to remove "flex" prefix - input() routine added to compressed and fast skeletons - unput() routine added to compressed skeleton - -d, -ce support for fast scanners - symbol table extended to avoid ugly casts of ints <-> char *'s; this may relieve MS-DOS woes - actions are now separated with YY_BREAK instead of simple "break"'s - fixed bug causing core-dumps if skeleton file could not be opened - fixed bugs in logic deciding which options cannot be intermixed - initial start condition can now be referred to as <INITIAL> - fixed bug which would incorrectly computer trailing context count for a pattern like "(foo){3}"; now this is considered "variable length", even though it isn't. - block comments allowed between rules - misc. typos corrected :MPW:MPW Tools:Tools with Source:flex ƒ:dfa.c
/* dfa - DFA construction routines *//* * Copyright (c) 1987, the University of California * * The United States Government has rights in this work pursuant to * contract no. DE-AC03-76SF00098 between the United States Department of * Energy and the University of California. * * This program may be redistributed. Enhancements and derivative works * may be created provided the new works, if made available to the general * public, are made available for use by anyone. */#include "flexdef.h"#ifdef macintosh#pragma segment _other#endif/* epsclosure - construct the epsilon closure of a set of ndfa states * * synopsis * int t[current_max_dfa_size], numstates, accset[accnum + 1], nacc; * int hashval; * int *epsclosure(); * t = epsclosure( t, &numstates, accset, &nacc, &hashval ); * * NOTES * the epsilon closure is the set of all states reachable by an arbitrary * number of epsilon transitions which themselves do not have epsilon * transitions going out, unioned with the set of states which have non-null * accepting numbers. t is an array of size numstates of nfa state numbers. * Upon return, t holds the epsilon closure and numstates is updated. accset * holds a list of the accepting numbers, and the size of accset is given * by nacc. t may be subjected to reallocation if it is not large enough * to hold the epsilon closure. * * hashval is the hash value for the dfa corresponding to the state set */int *epsclosure( t, ns_addr, accset, nacc_addr, hv_addr )int *t, *ns_addr, accset[], *nacc_addr, *hv_addr; { register int stkpos, ns, tsp; int numstates = *ns_addr, nacc, hashval, transsym, nfaccnum; int stkend, nstate; static int did_stk_init = false, *stk; #define MARK_STATE(state) \ trans1[state] = trans1[state] - MARKER_DIFFERENCE;#define IS_MARKED(state) (trans1[state] < 0)#define UNMARK_STATE(state) \ trans1[state] = trans1[state] + MARKER_DIFFERENCE;#define CHECK_ACCEPT(state) \ { \ nfaccnum = accptnum[state]; \ if ( nfaccnum != NIL ) \ accset[++nacc] = nfaccnum; \ }#define DO_REALLOCATION \ { \ current_max_dfa_size += MAX_DFA_SIZE_INCREMENT; \ ++num_reallocs; \ t = reallocate_integer_array( t, current_max_dfa_size ); \ stk = reallocate_integer_array( stk, current_max_dfa_size ); \ } \#define PUT_ON_STACK(state) \ { \ if ( ++stkend >= current_max_dfa_size ) \ DO_REALLOCATION \ stk[stkend] = state; \ MARK_STATE(state) \ }#define ADD_STATE(state) \ { \ if ( ++numstates >= current_max_dfa_size ) \ DO_REALLOCATION \ t[numstates] = state; \ hashval = hashval + state; \ }#define STACK_STATE(state) \ { \ PUT_ON_STACK(state) \ CHECK_ACCEPT(state) \ if ( nfaccnum != NIL || transchar[state] != SYM_EPSILON ) \ ADD_STATE(state) \ } if ( ! did_stk_init ) { stk = allocate_integer_array( current_max_dfa_size ); did_stk_init = true; } nacc = stkend = hashval = 0; for ( nstate = 1; nstate <= numstates; ++nstate ) { ns = t[nstate]; /* the state could be marked if we've already pushed it onto * the stack */ if ( ! IS_MARKED(ns) ) PUT_ON_STACK(ns) CHECK_ACCEPT(ns) hashval = hashval + ns; } for ( stkpos = 1; stkpos <= stkend; ++stkpos ) { ns = stk[stkpos]; transsym = transchar[ns]; if ( transsym == SYM_EPSILON ) { tsp = trans1[ns] + MARKER_DIFFERENCE; if ( tsp != NO_TRANSITION ) { if ( ! IS_MARKED(tsp) ) STACK_STATE(tsp) tsp = trans2[ns]; if ( tsp != NO_TRANSITION ) if ( ! IS_MARKED(tsp) ) STACK_STATE(tsp) } } } /* clear out "visit" markers */ for ( stkpos = 1; stkpos <= stkend; ++stkpos ) { if ( IS_MARKED(stk[stkpos]) ) { UNMARK_STATE(stk[stkpos]) } else flexfatal( "consistency check failed in epsclosure()" ); } *ns_addr = numstates; *hv_addr = hashval; *nacc_addr = nacc; return ( t ); }/* increase_max_dfas - increase the maximum number of DFAs */increase_max_dfas() { int old_max = current_max_dfas; current_max_dfas += MAX_DFAS_INCREMENT; ++num_reallocs; base = reallocate_integer_array( base, current_max_dfas ); def = reallocate_integer_array( def, current_max_dfas ); dfasiz = reallocate_integer_array( dfasiz, current_max_dfas ); accsiz = reallocate_integer_array( accsiz, current_max_dfas ); dhash = reallocate_integer_array( dhash, current_max_dfas ); todo = reallocate_integer_array( todo, current_max_dfas ); dss = reallocate_integer_pointer_array( dss, current_max_dfas ); dfaacc = reallocate_dfaacc_union( dfaacc, current_max_dfas ); /* fix up todo queue */ if ( todo_next < todo_head ) { /* queue was wrapped around the end */ register int i; for ( i = 0; i < todo_next; ++i ) todo[old_max + i] = todo[i]; todo_next += old_max; } }/* snstods - converts a set of ndfa states into a dfa state * * synopsis * int sns[numstates], numstates, newds, accset[accnum + 1], nacc, hashval; * int snstods(); * is_new_state = snstods( sns, numstates, accset, nacc, hashval, &newds ); * * on return, the dfa state number is in newds. */int snstods( sns, numstates, accset, nacc, hashval, newds_addr )int sns[], numstates, accset[], nacc, hashval, *newds_addr; { int didsort = 0; register int i, j; int newds, *oldsns; char *malloc(); for ( i = 1; i <= lastdfa; ++i ) if ( hashval == dhash[i] ) { if ( numstates == dfasiz[i] ) { oldsns = dss[i]; if ( ! didsort ) { /* we sort the states in sns so we can compare it to * oldsns quickly. we use bubble because there probably * aren't very many states */ bubble( sns, numstates ); didsort = 1; } for ( j = 1; j <= numstates; ++j ) if ( sns[j] != oldsns[j] ) break; if ( j > numstates ) { ++dfaeql; *newds_addr = i; return ( 0 ); } ++hshcol; } else ++hshsave; } /* make a new dfa */ if ( ++lastdfa >= current_max_dfas ) increase_max_dfas(); newds = lastdfa; if ( ! (dss[newds] = (int *) malloc( (unsigned) ((numstates + 1) * sizeof( int )) )) ) flexfatal( "dynamic memory failure in snstods()" ); /* if we haven't already sorted the states in sns, we do so now, so that * future comparisons with it can be made quickly */ if ( ! didsort ) bubble( sns, numstates ); for ( i = 1; i <= numstates; ++i ) dss[newds][i] = sns[i]; dfasiz[newds] = numstates; dhash[newds] = hashval; if ( nacc == 0 ) { dfaacc[newds].dfaacc_state = 0; accsiz[newds] = 0; } else if ( reject ) { /* we sort the accepting set in increasing order so the disambiguating * rule that the first rule listed is considered match in the event of * ties will work. We use a bubble sort since the list is probably * quite small. */ bubble( accset, nacc ); dfaacc[newds].dfaacc_set= (int *) malloc( (unsigned) ((nacc + 1) * sizeof( *dfaacc )) ); if ( ! dfaacc[newds].dfaacc_set) flexfatal( "dynamic memory failure in snstods()" ); /* save the accepting set for later */ for ( i = 1; i <= nacc; ++i ) dfaacc[newds].dfaacc_set[i] = accset[i]; accsiz[newds] = nacc; } else { /* find lowest numbered rule so the disambiguating rule will work */ j = accnum + 1; for ( i = 1; i <= nacc; ++i ) if ( accset[i] < j ) j = accset[i]; dfaacc[newds].dfaacc_state = j; } *dr = newds; return ( 1 ); }/* symfollowset - follow the symbol transitions one step * * synopsis * int ds[current_max_dfa_size], dsize, transsym; * int nset[current_max_dfa_size], numstates; * numstates = symfollowset( ds, dsize, transsym, nset ); */int symfollowset( ds, dsize, transsym, nset )int ds[], dsize, transsym, nset[]; { int ns, tsp, sym, i, j, lenccl, ch, numstates; int ccllist; numstates = 0; for ( i = 1; i <= dsize; ++i ) { /* for each nfa state ns in the state set of ds */ ns = ds[i]; sym = transchar[ns]; tsp = trans1[ns]; if ( sym < 0 ) { /* it's a character class */ sym = -sym; ccllist = cclmap[sym]; lenccl = ccllen[sym]; if ( cclng[sym] ) { for ( j = 0; j < lenccl; ++j ) { /* loop through negated character class */ ch = ccltbl[ccllist + j] & BYTEMASK; if ( ch > transsym ) break; /* transsym isn't in negated ccl */ else if ( ch == transsym ) /* next 2 */ goto bottom; } /* didn't find transsym in ccl */ nset[++numstates] = tsp; } else for ( j = 0; j < lenccl; ++j ) { ch = ccltbl[ccllist + j] & BYTEMASK; if ( ch > transsym ) break; else if ( ch == transsym ) { nset[++numstates] = tsp; break; } } } else if ( sym >= 'A' && sym <= 'Z' && caseins ) flexfatal( "consistency check failed in symfollowset" ); else if ( sym == SYM_EPSILON ) { /* do nothing */ } else if ( ecgroup[sym] == transsym ) nset[++numstates] = tsp;bottom: ; } return ( numstates ); }/* sympartition - partition characters with same out-transitions * * synopsis * integer ds[current_max_dfa_size], numstates, duplist[numecs]; * symlist[numecs]; * sympartition( ds, numstates, symlist, duplist ); */sympartition( ds, numstates, symlist, duplist )int ds[], numstates, duplist[];int symlist[]; { int tch, i, j, k, ns, dupfwd[CSIZE + 1], lenccl, cclp, ich; /* partitioning is done by creating equivalence classes for those * characters which have out-transitions from the given state. Thus * we are really creating equivalence classes of equivalence classes. */ for ( i = 1; i <= numecs; ++i ) { /* initialize equivalence class list */ duplist[i] = i - 1; dupfwd[i] = i + 1; } duplist[1] = NIL; dupfwd[numecs] = NIL; for ( i = 1; i <= numstates; ++i ) { ns = ds[i]; tch = transchar[ns]; if ( tch != SYM_EPSILON ) { if ( tch < -lastccl || tch > CSIZE ) flexfatal( "bad transition character detected in sympartition()" ); if ( tch > 0 ) { /* character transition */ mkechar( ecgroup[tch], dupfwd, duplist ); symlist[ecgroup[tch]] = 1; } else { /* character class */ tch = -tch; lenccl = ccllen[tch]; cclp = cclmap[tch]; mkeccl( ccltbl + cclp, lenccl, dupfwd, duplist, numecs ); if ( cclng[tch] ) { j = 0; for ( k = 0; k < lenccl; ++k ) { ich = ccltbl[cclp + k] & BYTEMASK; for ( ++j; j < ich; ++j ) symlist[j] = 1; } for ( ++j; j <= numecs; ++j ) symlist[j] = 1; } else for ( k = 0; k < lenccl; ++k ) { ich = ccltbl[cclp + k] & BYTEMASK; symlist[ich] = 1; } } } } } :MPW:MPW Tools:Tools with Source:flex ƒ:ecs.c
/* ecs - equivalence class routines *//* * Copyright (c) 1987, the University of California * * The United States Government has rights in this work pursuant to * contract no. DE-AC03-76SF00098 between the United States Department of * Energy and the University of California. * * This program may be redistributed. Enhancements and derivative works * may be created provided the new works, if made available to the general * public, are made available for use by anyone. */#include "flexdef.h"#ifdef macintosh#pragma segment _other#endif/* ccl2ecl - convert character classes to set of equivalence classes * * synopsis * ccl2ecl(); */ccl2ecl() { int i, ich, newlen, cclp, ccls, cclmec; for ( i = 1; i <= lastccl; ++i ) { /* we loop through each character class, and for each character * in the class, add the character's equivalence class to the * new "character" class we are creating. Thus when we are all * done, character classes will really consist of collections * of equivalence classes */ newlen = 0; cclp = cclmap[i]; for ( ccls = 0; ccls < ccllen[i]; ++ccls ) { ich = ccltbl[cclp + ccls] & BYTEMASK; cclmec = ecgroup[ich]; if ( cclmec > 0 ) { ccltbl[cclp + newlen] = cclmec; ++newlen; } } ccllen[i] = newlen; } }/* cre8ecs - associate equivalence class numbers with class members * * synopsis * int cre8ecs(); * number of classes = cre8ecs( fwd, bck, num ); * * fwd is the forward linked-list of equivalence class members. bck * is the backward linked-list, and num is the number of class members. * Returned is the number of classes. */int cre8ecs( fwd, bck, num )int fwd[], bck[], num; { int i, j, numcl; numcl = 0; /* create equivalence class numbers. From now on, abs( bck(x) ) * is the equivalence class number for object x. If bck(x) * is positive, then x is the representative of its equivalence * class. */ for ( i = 1; i <= num; ++i ) if ( bck[i] == NIL ) { bck[i] = ++numcl; for ( j = fwd[i]; j != NIL; j = fwd[j] ) bck[j] = -numcl; } return ( numcl ); }/* mkeccl - update equivalence classes based on character class xtions * * synopsis * char ccls[]; * int lenccl, fwd[llsiz], bck[llsiz], llsiz; * mkeccl( ccls, lenccl, fwd, bck, llsiz ); * * where ccls contains the elements of the character class, lenccl is the * number of elements in the ccl, fwd is the forward link-list of equivalent * characters, bck is the backward link-list, and llsiz size of the link-list * * Modified by Earle R. Horton, May, 1988 to allow for the possibility that * negative characters may be valid in the character set of the compiler. */mkeccl( ccls, lenccl, fwd, bck, llsiz )char ccls[];int lenccl, fwd[], bck[], llsiz; { int cclp, oldec, newec; int cclm, i, j; short *tmpccl; /* [ERH] Read chars into a short array on the stack. */ tmpccl = (short *)alloca(current_max_ccl_tbl_size * sizeof(short)); for (i=0; i < current_max_ccl_tbl_size; i++) tmpccl[i] = ccls[i] & BYTEMASK; /* note that it doesn't matter whether or not the character class is * negated. The same results will be obtained in either case. */ cclp = 0; while ( cclp < lenccl ) { cclm = tmpccl[cclp]; oldec = bck[cclm]; newec = cclm; j = cclp + 1; for ( i = fwd[cclm]; i != NIL && i <= llsiz; i = fwd[i] ) { /* look for the symbol in the character class */ for ( ; j < lenccl && tmpccl[j] <= i; ++j ) if ( tmpccl[j] == i ) { /* we found an old companion of cclm in the ccl. * link it into the new equivalence class and flag it as * having been processed */ bck[i] = newec; fwd[newec] = i; newec = i; tmpccl[j] = -i; /* set flag so we don't reprocess */ /* * [ERH] This trick will not work if negative characters are * valid. E.g. DEC multi-nationals, Macintosh option-characters. */ /* get next equivalence class member */ /* next 2 */ goto next_pt; } /* symbol isn't in character class. Put it in the old equivalence * class */ bck[i] = oldec; if ( oldec != NIL ) fwd[oldec] = i; oldec = i;next_pt: ; } if ( bck[cclm] != NIL || oldec != bck[cclm] ) { bck[cclm] = NIL; fwd[oldec] = NIL; } fwd[newec] = NIL; /* find next ccl member to process */ for ( ++cclp; tmpccl[cclp] < 0 && cclp < lenccl; ++cclp ) { /* reset "doesn't need processing" flag */ tmpccl[cclp] = -tmpccl[cclp]; } } /* [ERH] Feed shorts back into chars. */ for (i=0; i < current_max_ccl_tbl_size; i++) ccls[i] = tmpccl[i]; }/* mkechar - create equivalence class for single character * * synopsis * int tch, fwd[], bck[]; * mkechar( tch, fwd, bck ); */mkechar( tch, fwd, bck )int tch, fwd[], bck[]; { /* if until now the character has been a proper subset of * an equivalence class, break it away to create a new ec */ if ( fwd[tch] != NIL ) bck[fwd[tch]] = bck[tch]; if ( bck[tch] != NIL ) fwd[bck[tch]] = fwd[tch]; fwd[tch] = NIL; bck[tch] = NIL; } :MPW:MPW Tools:Tools with Source:flex ƒ:fastskeldef.h
/* macro definitions for fast/full-table C/FTL programs generated by flex */#include "flexskelcom.h"#define YY_END_OF_BUFFER_CHAR 0/* action number for "not an accepting state; back-track (not implemented)" */#define YY_BACK_TRACK 0/* action number for end-of-buffer was seen */#define YY_END_OF_BUFFER -3/* reinitializes everything except the current start condition. The last * input character is set to a newline so an initial beginning-of-line * rule will match */#define YY_FAST_INIT \ { \ yytext = yy_c_buf_p = &yy_ch_buf[1]; \ yyleng = 0; \ yy_hold_char = *yy_c_buf_p; \ }/* done before the next pattern has been matched action * change both of these if you change them at all! */#define YY_DO_BEFORE_SCAN \ *yy_c_buf_p = yy_hold_char#define YY_DO_BEFORE_RESTART \ yy_hold_char = *yy_c_buf_p/* done after the current pattern has been matched and before the * corresponding action */#define YY_DO_BEFORE_ACTION \ yytext = yy_b_buf_p; \ yyleng = YY_LENG; \ yy_hold_char = *yy_c_buf_p; \ *yy_c_buf_p = '\0'/* returns the length of the matched text */#define YY_LENG (yy_c_buf_p - yy_b_buf_p)#ifdef FLEX_FULL_TABLE#define YY_CS_TYPE int#else#define YY_CS_TYPE struct yy_trans_info *#endif/* find starting state */#ifdef FLEX_FULL_TABLE# define YY_FIND_START_STATE( x ) \ x = yy_start; \ if ( yy_b_buf_p[-1] == EOLCHAR ) \ ++x#else# define YY_FIND_START_STATE( x ) \ x = yy_state_ptr[yy_start]; \ if ( yy_b_buf_p[-1] == EOLCHAR ) \ x = yy_state_ptr[yy_start + 1]#endif# ifdef FLEX_USE_ECS# define yy_eq(x) e[x]# else# define yy_eq(x) x# endif/* get next jam state from packed table */#ifdef FLEX_FULL_TABLE# define YY_FIND_NEXT_MATCH \ { \ register int yy_state_info; \ while ( (yy_state_info = n[yy_current_state][yy_eq(*yy_c_buf_p)] ) != YY_JAM ) \ { \ yy_current_state = yy_state_info; \ YY_BACKTRACKING_ACTION \ yy_c_buf_p++; \ } \ }#else# define YY_FIND_NEXT_MATCH \ for ( yy_c = yy_eq(*yy_c_buf_p); \ (yy_trans_info = &yy_current_state[yy_c])->v == yy_c; \ yy_c = yy_eq(*++yy_c_buf_p) ) \ { \ yy_current_state += yy_trans_info->n; \ YY_BACKTRACKING_ACTION \ }#endif#ifdef FLEX_FULL_TABLE# define YY_FIND_ACTION( x ) x = l[yy_current_state]#else# define YY_FIND_ACTION( x ) x = yy_current_state[-1].n#endif#ifdef FLEX_FULL_TABLE# define YY_GET_NEXT_STATE yy_cur_state = n[yy_cur_state][*(yy_temp_char_ptr++)]#else# define YY_GET_NEXT_STATE yy_cur_state += yy_cur_state[*(yy_temp_char_ptr++)].n#endif#define EOB_ACT_RESTART_SCAN 2#define EOB_ACT_END_OF_FILE 3#define EOB_ACT_LAST_MATCH 4#ifdef FLEX_FULL_TABLE#define YY_DECLARE_YY_CS_PARAM int *yy_current_state#else#define YY_DECLARE_YY_CS_PARAM struct yy_trans_info *yy_current_state#endif :MPW:MPW Tools:Tools with Source:flex ƒ:fixasm.l
/* * This program fixes up MacsBug labels created by Aztec C * to be all upper case. It is meant to be used on the intermediate * assembler source output by Aztec C68K. * You need lex or flex for this one. */%{char ibuf[BUFSIZ*8];char obuf[BUFSIZ*8];main(){ setvbuf(stdin,ibuf,_IOFBF,sizeof(ibuf)); setvbuf(stdout,ibuf,_IOFBF,sizeof(obuf)); yylex();}%}%%\$[cedf][a-f0-9],\'.......\' { printf("$%c%c,'%c%c%c%c%c%c%c'", (yytext[1] >= 'e' ? yytext[1] - 2 : yytext[1]),yytext[2], toupper(yytext[5]), toupper(yytext[6]), toupper(yytext[7]), toupper(yytext[8]), toupper(yytext[9]), toupper(yytext[10]), toupper(yytext[11])); }%% :MPW:MPW Tools:Tools with Source:flex ƒ:flex.1
.TH FLEX 1 "13 May 1987".SH NAMEflex - fast lexical analyzer generator.SH SYNOPSIS.B flex[.B -dfirstvFILT -c[efmF] -Sskeleton_file] [ .I filename].SH DESCRIPTION.I flexis a rewrite of.I lexintended to right some of that tool's deficiencies: in particular,.I flexgenerates lexical analyzers much faster, and the analyzers usesmaller tables and run faster..SH OPTIONSIn addition to lex's.B -tflag, flex has the following options:.TP.B -dmakes the generated scanner run in.I debugmode. Whenever a pattern is recognized the scanner willwrite to.I stderra line of the form:.nf --accepting rule #n.fiRules are numbered sequentially with the first one being 1..TP.B -fhas the same effect as lex's -f flag (do not compress the scannertables); the mnemonic changes from.I fast compilationto (take your pick).I full tableor.I fast scanner.The actual compilation takes.I longer,since flex is I/O bound writing out the big table..IPThis option is equivalent to.B -cf(see below)..TP.B -iinstructs flex to generate a.I case-insensitivescanner. The case of letters given in the flex input patterns willbe ignored, and the rules will be matched regardless of case. Thematched text given in.I yytextwill have the preserved case (i.e., it will not be folded)..TP.B -rspecifies that the scanner uses the.B REJECTaction..TP.B -scauses the.I default rule(that unmatched scanner input is echoed to.I stdout)to be suppressed. If the scanner encounters input that does notmatch any of its rules, it aborts with an error. This option isuseful for finding holes in a scanner's rule set..TP.B -vhas the same meaning as for lex (print to.I stderra summary of statistics of the generated scanner). Many more statisticsare printed, though, and the summary spans several lines. Mostof the statistics are meaningless to the casual flex user..TP.B -Fspecifies that the.ulfastscanner table representation should be used. This representation isabout as fast as the full table representation.ul(-f),and for some sets of patterns will be considerably smaller (and forothers, larger). In general, if the pattern set contains both "keywords"and a catch-all, "identifier" rule, such as in the set:.nf "case" return ( TOK_CASE ); "switch" return ( TOK_SWITCH ); ... "default" return ( TOK_DEFAULT ); [a-z]+ return ( TOK_ID );.fithen you're better off using the full table representation. If onlythe "identifier" rule is present and you then use a hash table or some suchto detect the keywords, you're better off using.ul-F..IPThis option is equivalent to.B -cF(see below)..TP.B -Iinstructs flex to generate an.I interactivescanner. Normally, scanners generated by flex always look ahead one characterbefore deciding that a rule has been matched. At the possible cost of somescanning overhead (it's not clear that more overhead is involved), flex willgenerate a scanner which only looks ahead when needed. Such scanners arecalled.I interactivebecause if you want to write a scanner for an interactive system suchas a command shell, you will probably want the user's input to be terminatedwith a newline, and without.B -Ithe user will have to type a character in addition to the newline in orderto have the newline recognized. This leads to dreadful interactive performance..IPIf all this seems to confusing, here's the general rule: if a human willbe typing in input to your scanner, use.B -I,otherwise don't; if you don't care about how fast your scanners run anddon't want to make any assumptions about the input to your scanner,always use.B -I..IPNote,.B -Icannot be used in conjunction with.I fullor.I fast tables,i.e., the.B -f, -F, -cf,or.B -cFflags..TP.B -Linstructs flex to not generate.B #linedirectives (see below)..TP.B -Tmakes flex run in.I tracemode. It will generate a lot of messages to standard out concerningthe form of the input and the resultant non-deterministic and deterministicfinite automatons. This option is mostly for use in maintaining flex..TP .B -c[efmF]controls the degree of table compression..B -cedirects flex to construct.I equivalence classes,i.e., sets of characterswhich have identical lexical properties (for example, if the onlyappearance of digits in the flex input is in the character class"[0-9]" then the digits '0', '1', ..., '9' will all be putin the same equivalence class)..B -cfspecifies that the.I fullscanner tables should be generated - flex should not compress thetables by taking advantages of similar transition functions fordifferent states..B -cFspecifies that the alternate fast scanner representation (describedabove under the.B -Fflag)should be used..B -cmdirects flex to construct.I meta-equivalence classes,which are sets of equivalence classes (or characters, if equivalenceclasses are not being used) that are commonly used together.A lone.B -cspecifies that the scanner tables should be compressed but neitherequivalence classes nor meta-equivalence classes should be used..IPThe options.B -cfor.B -cFand.B -cmdo not make sense together - there is no opportunity for meta-equivalenceclasses if the table is not being compressed. Otherwise the optionsmay be freely mixed..IPThe default setting is.B -cemwhich specifies that flex should generate equivalence classesand meta-equivalence classes. This setting provides the highestdegree of table compression. You can trade offfaster-executing scanners at the cost of larger tables withthe following generally being true:.nf slowest smallest -cem -ce -cm -c -c{f,F}e -c{f,F} fastest largest.fi.TP.B -Sskeleton_fileoverrides the default skeleton file from which flex constructsits scanners. You'll never need this option unless you are doingflex maintenance or development..SH INCOMPATIBILITIES WITH LEX.I flexis fully compatible with.I lexwith the following exceptions:.IP -There is no run-time library to link with. You needn'tspecify.I -llwhen linking, and you must supply a main program. (Hacker's note: sincethe lex library contains a main() which simply calls yylex(), you actually.I canbe lazy and not supply your own main program and link with.I -ll.).IP -lex's.B %r(Ratfor scanners) and.B %t(translation table) optionsare not supported..IP -The do-nothing.ul-nflag is not supported..IP -When definitions are expanded, flex encloses them in parentheses.With lex, the following.nf NAME [A-Z][A-Z0-9]* %% foo{NAME}? printf( "Found it\\n" ); %%.fiwill not match the string "foo" because when the macrois expanded the rule is equivalent to "foo[A-Z][A-Z0-9]*?"and the precedence is such that the '?' is associated with"[A-Z0-9]*". With flex, the rule will be expanded to"foo([A-z][A-Z0-9]*)?" and so the string "foo" will match..IP -.B yymore()is not supported..IP -The undocumented lex-scanner internal variable.B yylinenois not supported..IP -If your input uses.B REJECT,you must run flex with the.B -rflag. If you leave out the flag, the scanner will abort at run-timewith a message that the scanner was compiled without the flag beingspecified..IP -The.B input()routine is not redefinable, though may be called to read charactersfollowing whatever has been matched by a rule. If.B input()encounters and end-of-file the normal.B yywrap()processing is done. A ``real'' end-of-file is returned as.I EOF..IPInput can be controlled by redefining the.B YY_INPUTmacro.YY_INPUT's calling sequence is "YY_INPUT(buf,result,max_size)". Itsaction is to place up to max_size characters in the character buffer "buf"and return in the integer variable "result" either thenumber of characters read or the constant YY_NULL (0 on Unix systems)systems) to indicate EOF. The default YY_INPUT reads from thefile-pointer "yyin" (which is by default.I stdin),so if youjust want to change the input file, you needn't redefineYY_INPUT - just point yyin at the input file..IPA sample redefinition of YY_INPUT (in the first section of the inputfile):.nf %{ #undef YY_INPUT #define YY_INPUT(buf,result,max_size) \\ result = (buf[0] = getchar()) == EOF ? YY_NULL : 1; %}.fiYou also can add in things like counting keeping track of theinput line number this way; but don't expect your scanner togo very fast..IP -.B output()is not supported.Output from the ECHO macro is done to the file-pointer"yyout" (default.I stdout)..IP -Trailing context is restricted to patterns which have eithera fixed-sized leading part or a fixed-sized trailing part.For example, "a*/b" and "a/b*" are okay, but not "a*/b*".This restriction is due to a bug in the trailing contextalgorithm given in.I Principles of Compiler Design(and.I Compilers - Principles, Techniques, and Tools)which can result in mismatches. Try the following lex program.nf %% x+/xy printf( "I found \\"%s\\"\\n", yytext );.fion the input "xxy". (If anyone knows of a fast algorithm forfinding the beginning of trailing context for an arbitrarypair of regular expressions, please let me know!)If you must have arbitrary trailing context, you can use.B yyless()to effect it..IP -flex reads only one input file, while lex's input is madeup of the concatenation of its input files..SH ENHANCEMENTS.IP -.I Exclusive start-conditionscan be declared by using.B %xinstead of.B %s.These start-conditions have the property that when they are active,.I no other rules are active.Thus a set of rules governed by the same exclusive start conditiondescribe a scanner which is independent of any of the other rules inthe flex input. This feature makes it easy to specify "mini-scanners"which scan portions of the input that are syntactically differentfrom the rest (e.g., comments)..IP -flex dynamically resizes its internal tables, so directives like "%a 3000"are not needed when specifying large scanners..IP -The scanning routine generated by flex is declared using the macro.B YY_DECL.By redefining this macro you can change the routine's name andits calling sequence. For example, you could use:.nf #undef YY_DECL #define YY_DECL float lexscan( a, b ) float a, b;.fito give it the name.I lexscan,returning a float, and taking two floats as arguments..IP -flex generates.B #linedirectives mapping lines in the output totheir origin in the input file..IP -You can put multiple actions on the same line, separated withsemi-colons. With lex, the following.nf foo handle_foo(); return 1;.fiis truncated to.nf foo handle_foo();.fiflex does not truncate the action. Actions that are not enclosed inbraces are terminated at the end of the line..IP -Actions can be begun with.B %{and terminated with.B %}.In this case, flex does not count braces to figure out where theaction ends - actions are terminated by the closing.B %}.This feature is useful when the enclosed action has extraneousbraces in it (usually in comments or inside inactive #ifdef's)that throw off the brace-count..IP -All of the scanner actions (e.g.,.B ECHO, yywrap ...)except the.B unput()and.B input()routines,are written as macros, so they can be redefined if necessarywithout requiring a separate library to link to..SH FILES.TP.I flex.skelskeleton scanner.TP.I flex.fastskelskeleton scanner for -f and -F.TP.I flexskelcom.hcommon definitions for skeleton files.TP.I flexskeldef.hdefinitions for compressed skeleton file.TP.I fastskeldef.hdefinitions for -f, -F skeleton file.SH "SEE ALSO".LPlex(1).LPM. E. Lesk and E. Schmidt,.I LEX - Lexical Analyzer Generator.SH AUTHORVern Paxson, with the help of many ideas and much inspiration fromVan Jacobson. Original version by Jef Poskanzer. Fast tablerepresentation is a partial implementation of a design done by VanJacobson. The implementation was done by Kevin Gong and Vern Paxson.ks to the many flex beta-testers, especially Casey Leedom,Nick Christopher, Chris Faylor, Eric Goldman, Craig Leres, Mohamed el Lozy,Esmond Pitt, Jef Poskanzer, and Dave Tallman. Thanks to John Gilmore,Bob Mulcahy,Rich Salz, and Richard Stallman for help with various distribution headaches..LPSend comments to:.nf Vern Paxson Real Time Systems Bldg. 46A Lawrence Berkeley Laboratory 1 Cyclotron Rd. Berkeley, CA 94720 (415) 486-6411 vern@lbl-{csam,rtsg}.arpa ucbvax!lbl-csam.arpa!vern.fi.SH DIAGNOSTICS.LP.I flex scanner jammed -a scanner compiled with.B -shas encountered an input string which wasn't matched byany of its rules..LP.I flex input buffer overflowed -a scanner rule matched a string long enough to overflow thescanner's internal input buffer (as large as.B BUFSIZin "/usr/include/stdio.h"). You can edit.I flexskelcom.hand increase.B YY_BUF_SIZEand.B YY_MAX_LINEto increase this limit..LP.I REJECT used and scanner was.I not generated using -r -just like it sounds. Your scanner uses.B REJECT.You must run flex on the scanner description using the.B -rflag..LP.I old-style lex command ignored -the flex input contains a lex command (e.g., "%n 1000") whichis being ignored..SH BUGS.LPUse of unput() or input() trashes the current yytext and yyleng..LPUse of unput() to push back more text than was matched canresult in the pushed-back text matching a beginning-of-line ('^')rule even though it didn't come at the beginning of the line..LPNulls are not allowed in flex inputs or in the inputs toscanners generated by flex. Their presence generates fatalerrors..LPDo not mix trailing context with the '|' operator used tospecify that multiple rules use the same action. That is,avoid constructs like:.nf foo/bar | bletch | bugprone { ... }.fiThey can result in subtle mismatches. This is actually nota problem if there is only one ruleusing trailing context and it is the first in the list (so theabove example will actually work okay). Theproblem is due to fall-through in the action switch statement,causing non-trailing-context rules to execute thetrailing-context code of their fellow rules. This shouldbe fixed, as it's a nasty bug and not obvious. The proper fix isfor flex to spit out a FLEX_TRAILING_CONTEXT_USED #define and thenhave the backup logic in a separate table which is consulted foreach rule-match, rather than as part of the rule action. Theplace to do the tweaking is in add_accept() - any kind soul wantto be a hero?.LPThe pattern:.nf x{3}.fiis considered to be variable-length for the purposes of trailingcontext, even though it has a clear fixed length..LPDue to both buffering of input and read-ahead, you cannot intermixcalls to, for example,.B getchar()with flex rules and expect it to work. Call.B input()instead..LPThe total table entries listed by the.B -vflag excludes the number of table entries needed to determinewhat rule has been matched. The number of entries is equalto the number of DFA states if the scanner was not compiledwith.B -r,and greater than the number of states if it was..LPThe scanner run-time speeds have not been optimized as muchas they deserve. Van Jacobson's work shows that the can go quitea bit faster still. :MPW:MPW Tools:Tools with Source:flex ƒ:flex.fastskel
/* A lexical scanner generated by flex */#define FLEX_FAST_SKEL#include "fastskeldef.h"%% section 1 code and the definition of YY_TRANS_OFFSET_TYPE, if needed, go here#ifndef FLEX_FULL_TABLE /* struct for yy_transition */ struct yy_trans_info { /* v is a verify for a transition. */ short v; /* In cases where its sister v *is* a "yes, there is a transition", * n is* the offset (in records) to the next state. In most cases * where there is no transition, the value of n is irrelevant. If n * is the -1th record of a state, though, then n is the action * number for that state */ YY_TRANS_OFFSET_TYPE n; };#endif%% data tables for DFA go here/* these declarations have to come after the section 1 code or lint gets * confused about whether the variables are used */FILE *yyin = stdin, *yyout = stdout;/* these variables are all declared out here so that section 3 code can * manipulate them */static char *yy_c_buf_p; /* points to current character in buffer */static char *yy_b_buf_p; /* points to start of current scan */static int yy_init = 1; /* whether we need to initialize */static int yy_start; /* start state number *//* true when we've seen an EOF for the current input file */static int yy_eof_has_been_seen;static int yy_n_chars; /* number of characters read into yy_ch_buf *//* yy_ch_buf has to be 2 characters longer than YY_BUF_SIZE because we need * to put in 2 end-of-buffer characters (this is explained where it is * done) at the end of yy_ch_buf */#ifdef MALLOC_BUFFERSstatic char *yy_ch_buf = 0L;#elsestatic char yy_ch_buf[YY_BUF_SIZE + 2];#endif/* yy_hold_char holds the character lost when yytext is formed */static char yy_hold_char;char *yytext;static int yyleng; /* length of yytext */static YY_CS_TYPE yy_last_accepting_state;static char *yy_last_accepting_cpos;static YY_CS_TYPE yy_get_previous_state();static int yy_get_next_buffer();#define FLEX_USES_BACKTRACKING#ifdef FLEX_USES_BACKTRACKING# ifdef FLEX_FULL_TABLE# define YY_BACKTRACKING_ACTION \ if ( l[yy_current_state] ) \ { \ yy_last_accepting_state = yy_current_state; \ yy_last_accepting_cpos = yy_c_buf_p; \ }# else# define YY_BACKTRACKING_ACTION \ if ( yy_current_state[-1].n ) \ { \ yy_last_accepting_state = yy_current_state; \ yy_last_accepting_cpos = yy_c_buf_p; \ }# endif#else# define YY_BACKTRACKING_ACTION#endifYY_DECL { register YY_CS_TYPE yy_current_state; register int yy_c; register struct yy_trans_info *yy_trans_info; register int yy_act;%% user's declarations go here#ifdef MALLOC_BUFFERS if(yy_ch_buf == 0L){ yy_ch_buf = (char *)malloc(YY_BUF_SIZE + 2); if(yy_ch_buf == 0L){ fprintf( stderr, "Out of memory\n"); exit(-1); } }#endif if ( yy_init ) { yy_start = 1; /* first start state */new_file: /* this is where we enter upon encountering and end-of-file and * yywrap() indicating that we should continue processing */ /* we put in the '\n' and start reading from [1] so that an * initial match-at-newline will be true. */ yy_ch_buf[0] = EOLCHAR; yy_n_chars = 1; /* we always need two end-of-buffer characters. The first causes * a transition to the end-of-buffer state. The second causes * a jam in that state. */ yy_ch_buf[yy_n_chars] = YY_END_OF_BUFFER_CHAR; yy_ch_buf[yy_n_chars + 1] = YY_END_OF_BUFFER_CHAR; yy_eof_has_been_seen = 0; YY_FAST_INIT; yy_init = 0; } while ( 1 ) /* loops until end-of-file is reached */ { /* support of yytext and yyleng */ YY_DO_BEFORE_SCAN; /* yy_b_buf_p points to the position in yy_ch_buf of the start of the * current run. */ yy_b_buf_p = yy_c_buf_p; YY_FIND_START_STATE( yy_current_state ); YY_FIND_NEXT_MATCH; YY_DO_BEFORE_ACTION;/* we need this label to process the very last action (right before the end of * the file) */do_action: YY_FIND_ACTION( yy_act );#ifdef FLEX_DEBUG fprintf( stderr, "--accepting rule #%d\n", yy_act );#endif switch ( yy_act ) {%% actions go here case YY_BACK_TRACK: YY_DO_BEFORE_SCAN; /* undo the effects of YY_DO_BEFORE_ACTION */ yy_c_buf_p = yy_last_accepting_cpos + 1; yy_current_state = yy_last_accepting_state; YY_DO_BEFORE_ACTION; goto do_action; case YY_NEW_FILE: break; /* begin reading from new file */ case YY_DO_DEFAULT: /* we have to eat up one character and recompute yytext and * yyleng */ YY_DO_BEFORE_SCAN; /* undo the effects of YY_DO_BEFORE_ACTION */ ++yy_c_buf_p; YY_DO_BEFORE_ACTION; YY_DEFAULT_ACTION; break; case YY_END_OF_BUFFER: YY_DO_BEFORE_SCAN; /* undo the effects of YY_DO_BEFORE_ACTION */ switch ( yy_get_next_buffer() ) { case EOB_ACT_END_OF_FILE: { if ( yywrap() ) { /* note: because we've taken care in * yy_get_next_buffer() to have set up yy_b_buf_p, * we can now set up yy_c_buf_p so that if some * total hoser (like flex itself) wants * to call the scanner after we return the * YY_NULL, it'll still work - another YY_NULL * will get returned. */ yy_c_buf_p = yy_b_buf_p; return ( YY_NULL ); } else goto new_file; } break; case EOB_ACT_RESTART_SCAN: yy_c_buf_p = yy_b_buf_p; YY_DO_BEFORE_RESTART; break; case EOB_ACT_LAST_MATCH: yy_c_buf_p = &yy_ch_buf[yy_n_chars]; yy_current_state = yy_get_previous_state(); YY_DO_BEFORE_ACTION; goto do_action; } break; default: printf( "action # %d\n", yy_act ); YY_FATAL_ERROR( "fatal flex scanner internal error" ); } } }/* yy_get_next_buffer - try to read in new buffer * * synopsis * int yy_get_next_buffer(); * * returns a code representing an action * EOB_ACT_LAST_MATCH - * EOB_ACT_RESTART_SCAN - restart the scanner * EOB_ACT_END_OF_FILE - end of file */static int yy_get_next_buffer() { if ( yy_c_buf_p != &yy_ch_buf[yy_n_chars + 1] ) { YY_FATAL_ERROR( "NULL in input" ); /*NOTREACHED*/ } else { /* try to read more data */ register char *dest = yy_ch_buf; register char *source = yy_b_buf_p - 1; /* copy prev. char, too */ register int number_to_move, i; int ret_val; /* first move last chars to start of buffer */ number_to_move = yy_c_buf_p - yy_b_buf_p; for ( i = 0; i < number_to_move; ++i ) *(dest++) = *(source++); if ( yy_eof_has_been_seen ) /* don't do the read, it's not guaranteed to return an EOF, * just force an EOF */ yy_n_chars = 0; else /* read in more data */ YY_INPUT( (&yy_ch_buf[number_to_move]), yy_n_chars, YY_BUF_SIZE - number_to_move - 1 ); if ( yy_n_chars == 0 ) { if ( number_to_move == 1 ) ret_val = EOB_ACT_END_OF_FILE; else ret_val = EOB_ACT_LAST_MATCH; yy_eof_has_been_seen = 1; } else ret_val = EOB_ACT_RESTART_SCAN; yy_n_chars += number_to_move; yy_ch_buf[yy_n_chars] = YY_END_OF_BUFFER_CHAR; yy_ch_buf[yy_n_chars + 1] = YY_END_OF_BUFFER_CHAR; /* yy_b_buf_p begins at the second character in * yy_ch_buf; the first character is the one which * preceded it before reading in the latest buffer; * it needs to be kept around in case it's a * newline, so yy_get_previous_state() will have * with '^' rules active */ yy_b_buf_p = &yy_ch_buf[1]; return ( ret_val ); } }/* yy_get_previous_state - get the state just before the eob char was reached * * synopsis * YY_CS_TYPE yy_get_previous_state(); */static YY_CS_TYPE yy_get_previous_state() { register YY_CS_TYPE yy_cur_state; register char *yy_temp_char_ptr; YY_FIND_START_STATE( yy_cur_state ); for ( yy_temp_char_ptr = yy_b_buf_p; yy_temp_char_ptr < yy_c_buf_p; ) YY_GET_NEXT_STATE; return ( yy_cur_state ); }static unput( c )int c; { YY_DO_BEFORE_SCAN; /* undo effects of setting up yytext */ if ( yy_c_buf_p < yy_ch_buf + 2 ) { /* need to shift things up to make room */ register int number_to_move = yy_n_chars + 2; /* +2 for EOB chars */ register char *dest = &yy_ch_buf[YY_BUF_SIZE + 2]; register char *source = &yy_ch_buf[number_to_move]; while ( source > yy_ch_buf ) *--dest = *--source; yy_c_buf_p += dest - source; yy_b_buf_p += dest - source; if ( yy_c_buf_p < yy_ch_buf + 2 ) YY_FATAL_ERROR( "flex scanner push-back overflow" ); } if ( yy_c_buf_p > yy_b_buf_p && yy_c_buf_p[-1] == EOLCHAR ) yy_c_buf_p[-2] = EOLCHAR; *--yy_c_buf_p = c; YY_DO_BEFORE_ACTION; /* set up yytext again */ }static int input() { int c; YY_DO_BEFORE_SCAN; if ( *yy_c_buf_p == YY_END_OF_BUFFER_CHAR ) { /* need more input */ yy_b_buf_p = yy_c_buf_p; ++yy_c_buf_p; switch ( yy_get_next_buffer() ) { /* this code, unfortunately, is somewhat redundant with * that above */ case EOB_ACT_END_OF_FILE: { if ( yywrap() ) { yy_c_buf_p = yy_b_buf_p; return ( EOF ); } yy_ch_buf[0] = EOLCHAR; yy_n_chars = 1; yy_ch_buf[yy_n_chars] = YY_END_OF_BUFFER_CHAR; yy_ch_buf[yy_n_chars + 1] = YY_END_OF_BUFFER_CHAR; yy_eof_has_been_seen = 0; YY_FAST_INIT; return ( input() ); } break; case EOB_ACT_RESTART_SCAN: yy_c_buf_p = yy_b_buf_p; break; case EOB_ACT_LAST_MATCH: YY_FATAL_ERROR( "unexpected last match in input()" ); } } c = *yy_c_buf_p++ & BYTEMASK; YY_DO_BEFORE_RESTART; return ( c ); } :MPW:MPW Tools:Tools with Source:flex ƒ:flex.man.page
FLEX(1) UNIX Programmer's Manual FLEX(1)NAME flex - fast lexical analyzer generatorSYNOPSIS flex [ -dfirstvFILT -c[efmF] -Sskeleton_file ] [ filename ]DESCRIPTION flex is a rewrite of lex intended to right some of that tool's deficiencies: in particular, flex generates lexical analyzers much faster, and the analyzers use smaller tables and run faster.OPTIONS In addition to lex's -t flag, flex has the following options: -d makes the generated scanner run in debug mode. When- ever a pattern is recognized the scanner will write to stderr a line of the form: --accepting rule #n Rules are numbered sequentially with the first one being 1. -f has the same effect as lex's -f flag (do not compress the scanner tables); the mnemonic changes from fast compilation to (take your pick) full table or fast scanner. The actual compilation takes longer, since flex is I/O bound writing out the big table. This option is equivalent to -cf (see below). -i instructs flex to generate a case-insensitive scanner. The case of letters given in the flex input patterns will be ignored, and the rules will be matched regard- less of case. The matched text given in yytext will have the preserved case (i.e., it will not be folded). -r specifies that the scanner uses the REJECT action. -s causes the default rule (that unmatched scanner input is echoed to stdout) to be suppressed. If the scanner encounters input that does not match any of its rules, it aborts with an error. This option is useful for finding holes in a scanner's rule set. -v has the same meaning as for lex (print to stderr a sum- mary of statistics of the generated scanner). Many more statistics are printed, though, and the summary spans several lines. Most of the statistics are mean- ingless to the casual flex user. -F specifies that the fast scanner table representation should be used. This representation is about as fast as the full table representation (-f), and for some sets of patterns will be considerably smaller (and for others, larger). In general, if the pattern set con- tains both "keywords" and a catch-all, "identifier" rule, such as in the set: "case" return ( TOK_CASE ); "switch" return ( TOK_SWITCH ); ... "default" return ( TOK_DEFAULT ); [a-z]+ return ( TOK_ID ); then you're better off using the full table representa- tion. If only the "identifier" rule is present and you then use a hash table or some such to detect the key- words, you're better off using -F. This option is equivalent to -cF (see below). -I instructs flex to generate an interactive scanner. Normally, scanners generated by flex always look ahead one character before deciding that a rule has been matched. At the possible cost of some scanning over- head (it's not clear that more overhead is involved), flex will generate a scanner which only looks ahead when needed. Such scanners are called interactive because if you want to write a scanner for an interac- tive system such as a command shell, you will probably want the user's input to be terminated with a newline, and without -I the user will have to type a character in addition to the newline in order to have the newline recognized. This leads to dreadful interactive perfor- mance. If all this seems to confusing, here's the general rule: if a human will be typing in input to your scanner, use -I, otherwise don't; if you don't care about how fast your scanners run and don't want to make any assumptions about the input to your scanner, always use -I. Note, -I cannot be used in conjunction with full or fast tables, i.e., the -f, -F, -cf, or -cF flags. -L instructs flex to not generate #line directives (see below). -T makes flex run in trace mode. It will generate a lot of messages to standard out concerning the form of the input and the resultant non-deterministic and deterministic finite automatons. This option is mostly for use in maintaining flex. -c[efmF] controls the degree of table compression. -ce directs flex to construct equivalence classes, i.e., sets of characters which have identical lexical properties (for example, if the only appearance of digits in the flex input is in the character class "[0-9]" then the digits '0', '1', ..., '9' will all be put in the same equivalence class). -cf specifies that the full scanner tables should be generated - flex should not compress the tables by taking advantages of similar transition functions for different states. -cF speci- fies that the alternate fast scanner representation (described above under the -F flag) should be used. - cm directs flex to construct meta-equivalence classes, which are sets of equivalence classes (or characters, if equivalence classes are not being used) that are commonly used together. A lone -c specifies that the scanner tables should be compressed but neither equivalence classes nor meta-equivalence classes should be used. The options -cf or -cF and -cm do not make sense together - there is no opportunity for meta-equivalence classes if the table is not being compressed. Other- wise the options may be freely mixed. The default setting is -cem which specifies that flex should generate equivalence classes and meta- equivalence classes. This setting provides the highest degree of table compression. You can trade off faster-executing scanners at the cost of larger tables with the following generally being true: slowest smallest -cem -ce -cm -c -c{f,F}e -c{f,F} fastest largest -Sskeleton_file overrides the default skeleton file from which flex constructs its scanners. You'll never need this option unless you are doing flex maintenance or development.INCOMPATIBILITIES WITH LEX flex is fully compatible with lex with the following excep- tions: - There is no run-time library to link with. You needn't specify -ll when linking, and you must supply a main program. (Hacker's note: since the lex library con- tains a main() which simply calls yylex(), you actually can be lazy and not supply your own main program and link with -ll.) - lex's %r (Ratfor scanners) and %t (translation table) options are not supported. - The do-nothing -n flag is not supported. - When definitions are expanded, flex encloses them in parentheses. With lex, the following NAME [A-Z][A-Z0-9]* %% foo{NAME}? printf( "Found it\n" ); %% will not match the string "foo" because when the macro is expanded the rule is equivalent to "foo[A-Z][A-Z0- 9]*?" and the precedence is such that the '?' is asso- ciated with "[A-Z0-9]*". With flex, the rule will be expanded to "foo([A-z][A-Z0-9]*)?" and so the string "foo" will match. - yymore() is not supported. - The undocumented lex-scanner internal variable yylineno is not supported. - If your input uses REJECT, you must run flex with the -r flag. If you leave out the flag, the scanner will abort at run-time with a message that the scanner was compiled without the flag being specified. - The input() routine is not redefinable, though may be called to read characters following whatever has been matched by a rule. If input() encounters and end-of- file the normal yywrap() processing is done. A ``real'' end-of-file is returned as EOF. Input can be controlled by redefining the YY_INPUT macro. YY_INPUT's calling sequence is "YY_INPUT(buf,result,max_size)". Its action is to place up to max_size characters in the character buffer "buf" and return in the integer variable "result" either the number of characters read or the constant YY_NULL (0 on Unix systems) systems) to indicate EOF. The default YY_INPUT reads from the file-pointer "yyin" (which is by default stdin), so if you just want to change the input file, you needn't redefine YY_INPUT - just point yyin at the input file. A sample redefinition of YY_INPUT (in the first section of the input file): %{ #undef YY_INPUT #define YY_INPUT(buf,result,max_size) \ result = (buf[0] = getchar()) == EOF ? YY_NULL : 1; %} You also can add in things like counting keeping track of the input line number this way; but don't expect your scanner to go very fast. - output() is not supported. Output from the ECHO macro is done to the file-pointer "yyout" (default stdout). - Trailing context is restricted to patterns which have either a fixed-sized leading part or a fixed-sized trailing part. For example, "a*/b" and "a/b*" are okay, but not "a*/b*". This restriction is due to a bug in the trailing context algorithm given in Princi- ples of Compiler Design (and Compilers - Principles, Techniques, and Tools) which can result in mismatches. Try the following lex program %% x+/xy printf( "I found \"%s\"\n", yytext ); on the input "xxy". (If anyone knows of a fast algo- rithm for finding the beginning of trailing context for an arbitrary pair of regular expressions, please let me know!) If you must have arbitrary trailing context, you can use yyless() to effect it. - flex reads only one input file, while lex's input is made up of the concatenation of its input files.ENHANCEMENTS - Exclusive start-conditions can be declared by using %x instead of %s. These start-conditions have the property that when they are active, no other rules are active. Thus a set of rules governed by the same exclusive start condition describe a scanner which is independent of any of the other rules in the flex input. This feature makes it easy to specify "mini-scanners" which scan portions of the input that are syntactically dif- ferent from the rest (e.g., comments). - flex dynamically resizes its internal tables, so direc- tives like "%a 3000" are not needed when specifying large scanners. - The scanning routine generated by flex is declared using the macro YY_DECL. By redefining this macro you can change the routine's name and its calling sequence. For example, you could use: #undef YY_DECL #define YY_DECL float lexscan( a, b ) float a, b; to give it the name lexscan, returning a float, and taking two floats as arguments. - flex generates #line directives mapping lines in the output to their origin in the input file. - You can put multiple actions on the same line, separated with semi-colons. With lex, the following foo handle_foo(); return 1; is truncated to foo handle_foo(); flex does not truncate the action. Actions that are not enclosed in braces are terminated at the end of the line. - Actions can be begun with %{ and terminated with %}. In this case, flex does not count braces to figure out where the action ends - actions are terminated by the closing %}. This feature is useful when the enclosed action has extraneous braces in it (usually in comments or inside inactive #ifdef's) that throw off the brace- count. - All of the scanner actions (e.g., ECHO, yywrap ...) except the unput() and input() routines, are written as macros, so they can be redefined if necessary without requiring a separate library to link to.FILES flex.skel skeleton scanner flex.fastskel skeleton scanner for -f and -F flexskelcom.h common definitions for skeleton files flexskeldef.h definitions for compressed skele fastskeldef.h definitions for -f, -F skeleton fileSEE ALSO lex(1) M. E. Lesk and E. Schmidt, LEX - Lexical Analyzer GeneratorAUTHOR Vern Paxson, with the help of many ideas and much inspira- tion from Van Jacobson. Original version by Jef Poskanzer. Fast table representation is a partial implementation of a design done by Van Jacobson. The implementation was done by Kevin Gong and Vern Paxson. Thanks to the many flex beta-testers, especially Casey Lee- dom, Nick Christopher, Chris Faylor, Eric Goldman, Craig Leres, Mohamed el Lozy, Esmond Pitt, Jef Poskanzer, and Dave Tallman. Thanks to John Gilmore, Bob Mulcahy, Rich Salz, and Richard Stallman for help with various distribution headaches. Send comments to: Vern Paxson Real Time Systems Bldg. 46A Lawrence Berkeley Laboratory 1 Cyclotron Rd. Berkeley, CA 94720 (415) 486-6411 vern@lbl-{csam,rtsg}.arpa ucbvax!lbl-csam.arpa!vernDIAGNOSTICS flex scanner jammed - a scanner compiled with -s has encoun- tered an input string which wasn't matched by any of its rules. flex input buffer overflowed - a scanner rule matched a string long enough to overflow the scanner's internal input buffer (as large as BUFSIZ in "/usr/include/stdio.h"). You can edit flexskelcom.h and increase YY_BUF_SIZE and YY_MAX_LINE to increase this limit. REJECT used and scanner was not generated using -r - just like it sounds. Your scanner uses REJECT. You must run flex on the scanner description using the -r flag. old-style lex command ignored - the flex input contains a lex command (e.g., "%n 1000") which is being ignored.BUGS Use of unput() or input() trashes the current yytext and yyleng. Use of unput() to push back more text than was matched can result in the pushed-back text matching a beginning-of-line ('^') rule even though it didn't come at the beginning of the line. Nulls are not allowed in flex inputs or in the inputs to scanners generated by flex. Their presence generates fatal errors. Do not mix trailing context wit
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:flex ƒ:flex.man.page
+++++ Continued from previous card +++++
h the '|' operator used to specify that multiple rules use the same action. That is, avoid constructs like: foo/bar | bletch | bugprone { ... } They can result in subtle mismatches. This is actually not a problem if there is only one rule using trailing context and it is the first in the list (so the above example will actually work okay). The problem is due to fall-through in the action switch statement, causing non-trailing-context rules to execute the trailing-context code of their fellow rules. This should be fixed, as it's a nasty bug and not obvious. The proper fix is for flex to spit out a FLEX_TRAILING_CONTEXT_USED #define and then have the backup logic in a separate table which is consulted for each rule- match, rather than as part of the rule action. The place to do the tweaking is in add_accept() - any kind soul want to be a hero? The pattern: x{3} is considered to be variable-length for the purposes of trailing context, even though it has a clear fixed length. Due to both buffering of input and read-ahead, you cannot intermix calls to, for example, getchar() with flex rules and expect it to work. Call input() instead. The total table entries listed by the -v flag excludes the number of table entries needed to determine what rule has been matched. The number of entries is equal to the number of DFA states if the scanner was not compiled with -r, and greater than the number of states if it was. The scanner run-time speeds have not been optimized as much as they deserve. Van Jacobson's work shows that they can go quite a bit faster still. :MPW:MPW Tools:Tools with Source:flex ƒ:flex.skel
/* A lexical scanner generated by flex */#include "flexskeldef.h"%% section 1 code and data tables for DFA go here/* these declarations have to come after the section 1 code or lint gets * confused about whether the variables are used */FILE *yyin = stdin, *yyout = stdout;/* these variables are all declared out here so that section 3 code can * manipulate them */static int yy_start, yy_b_buf_p, yy_c_buf_p, yy_e_buf_p;static int yy_saw_eof, yy_init = 1;/* yy_ch_buf has to be 1 character longer than YY_BUF_SIZE, since when * setting up yytext we can try to put a '\0' just past the end of the * matched text */#ifdef MALLOC_BUFFERSstatic char *yy_ch_buf = 0L;static int *yy_st_buf = 0L;#elsestatic char yy_ch_buf[YY_BUF_SIZE + 1];static int yy_st_buf[YY_BUF_SIZE];#endifstatic char yy_hold_char;char *yytext;static int yyleng;YY_DECL { int yy_n_chars, yy_lp, yy_iii, yy_buf_pos, yy_act;%% user's declarations go here#ifdef MALLOC_BUFFERS if(yy_ch_buf == 0L){ yy_ch_buf = (char *)malloc(YY_BUF_SIZE + 1); yy_st_buf = (int *)malloc(YY_BUF_SIZE * sizeof(int)); if(yy_ch_buf == 0L || yy_st_buf == 0L){ fprintf( stderr, "Out of memory\n"); exit(-1); } }#endif if ( yy_init ) { YY_INIT; yy_start = 1; yy_init = 0; } goto get_next_token;do_action: for ( ; ; ) { YY_DO_BEFORE_ACTION#ifdef FLEX_DEBUG fprintf( stderr, "--accepting rule #%d\n", yy_act );#endif switch ( yy_act ) {%% actions go herecase YY_NEW_FILE:break; /* begin reading from new file */case YY_DO_DEFAULT:YY_DEFAULT_ACTION;break;case YY_END_TOK:return ( YY_END_TOK );default:YY_FATAL_ERROR( "fatal flex scanner internal error" ); }get_next_token: { register int yy_curst; register char yy_sym; YY_DO_BEFORE_SCAN /* set up to begin running DFA */ yy_curst = yy_start; if ( yy_ch_buf[yy_c_buf_p] == EOLCHAR ) ++yy_curst; /* yy_b_buf_p points to the position in yy_ch_buf * of the start of the current run. */ yy_b_buf_p = yy_c_buf_p + 1; do /* until the machine jams */ { if ( yy_c_buf_p == yy_e_buf_p ) { /* need more input */ if ( yy_e_buf_p >= YY_BUF_LIM ) { /* not enough room to do another read */ /* see if we can make some room for more chars */ yy_n_chars = yy_e_buf_p - yy_b_buf_p; if ( yy_n_chars >= 0 ) /* shift down buffer to make room */ for ( yy_iii = 0; yy_iii <= yy_n_chars; ++yy_iii ) { yy_buf_pos = yy_b_buf_p + yy_iii; yy_ch_buf[yy_iii] = yy_ch_buf[yy_buf_pos]; yy_st_buf[yy_iii] = yy_st_buf[yy_buf_pos]; } yy_b_buf_p = 0; yy_e_buf_p = yy_n_chars; if ( yy_e_buf_p >= YY_BUF_LIM ) YY_FATAL_ERROR( "flex input buffer overflowed" ); yy_c_buf_p = yy_e_buf_p; } else if ( yy_saw_eof ) {saweof: if ( yy_b_buf_p > yy_e_buf_p ) { if ( yywrap() ) { yy_act = YY_END_TOK; goto do_action; } else { YY_INIT; yy_act = YY_NEW_FILE; goto do_action; } } else /* do a jam to eat up more input */ {#ifndef FLEX_INTERACTIVE_SCANNER /* we're going to decrement yy_c_buf_p upon doing * the jam. In this case, that's wrong, since * it points to the last non-jam character. So * we increment it now to counter the decrement. */ ++yy_c_buf_p;#endif break; } } YY_INPUT( (yy_ch_buf + yy_c_buf_p + 1), yy_n_chars, YY_MAX_LINE ); if ( yy_n_chars == YY_NULL ) { if ( yy_saw_eof ) YY_FATAL_ERROR( "flex scanner saw EOF twice - shouldn't happen" ); yy_saw_eof = 1; goto saweof; } yy_e_buf_p += yy_n_chars; } ++yy_c_buf_p;#ifdef FLEX_USE_ECS yy_sym = e[(yy_ch_buf[yy_c_buf_p] & BYTEMASK)];#else yy_sym = yy_ch_buf[yy_c_buf_p];#endif#ifdef FLEX_FULL_TABLE yy_curst = n[yy_curst][yy_sym];#else /* get next state from compressed table */ while ( c[b[yy_curst] + yy_sym] != yy_curst ) { yy_curst = d[yy_curst];#ifdef FLEX_USE_MECS /* we've arrange it so that templates are never chained * to one another. This means we can afford make a * very simple test to see if we need to convert to * yy_sym's meta-equivalence class without worrying * about erroneously looking up the meta-equivalence * class twice */ if ( yy_curst >= YY_TEMPLATE ) yy_sym = m[yy_sym];#endif } yy_curst = n[b[yy_curst] + yy_sym];#endif yy_st_buf[yy_c_buf_p] = yy_curst; }#ifdef FLEX_INTERACTIVE_SCANNER while ( b[yy_curst] != YY_JAM_BASE );#else while ( yy_curst != YY_JAM ); --yy_c_buf_p; /* put back character we jammed on */#endif if ( yy_c_buf_p >= yy_b_buf_p ) { /* we matched some text */ yy_curst = yy_st_buf[yy_c_buf_p]; yy_lp = l[yy_curst];#ifdef FLEX_REJECT_ENABLEDfind_rule: /* we branch to this label when doing a REJECT */#endif for ( ; ; ) /* until we find what rule we matched */ {#ifdef FLEX_REJECT_ENABLED if ( yy_lp && yy_lp < l[yy_curst + 1] ) { yy_act = a[yy_lp]; goto do_action; /* "continue 2" */ }#else if ( yy_lp ) { yy_act = yy_lp; goto do_action; /* "continue 2" */ }#endif if ( --yy_c_buf_p < yy_b_buf_p ) break; yy_curst = yy_st_buf[yy_c_buf_p]; yy_lp = l[yy_curst]; } } /* if we got this far, then we didn't find any accepting * states */ /* so that the default applies to the first char read */ ++yy_c_buf_p; yy_act = YY_DO_DEFAULT; } } /*NOTREACHED*/ }static int unput( c )char c; { YY_DO_BEFORE_SCAN; /* undo effects of setting up yytext */ if ( yy_c_buf_p == 0 ) { register int i; register int yy_buf_pos = YY_BUF_MAX; for ( i = yy_e_buf_p; i >= yy_c_buf_p; --i ) { yy_ch_buf[yy_buf_pos] = yy_ch_buf[i]; yy_st_buf[yy_buf_pos] = yy_st_buf[i]; --yy_buf_pos; } yy_c_buf_p = YY_BUF_MAX - yy_e_buf_p; yy_e_buf_p = YY_BUF_MAX; } if ( yy_c_buf_p <= 0 ) YY_FATAL_ERROR( "flex scanner push-back overflow" ); if ( yy_c_buf_p >= yy_b_buf_p && yy_ch_buf[yy_c_buf_p] == EOLCHAR ) yy_ch_buf[yy_c_buf_p - 1] = EOLCHAR; yy_ch_buf[yy_c_buf_p--] = c; YY_DO_BEFORE_ACTION; /* set up yytext again */ }static int input() { int c; YY_DO_BEFORE_SCAN if ( yy_c_buf_p == yy_e_buf_p ) { /* need more input */ int yy_n_chars; /* we can throw away the entire current buffer */ if ( yy_saw_eof ) { if ( yywrap() ) return ( EOF ); YY_INIT; } yy_b_buf_p = 0; YY_INPUT( yy_ch_buf, yy_n_chars, YY_MAX_LINE ); if ( yy_n_chars == YY_NULL ) { yy_saw_eof = 1; if ( yywrap() ) return ( EOF ); YY_INIT; return ( input() ); } yy_c_buf_p = -1; yy_e_buf_p = yy_n_chars - 1; } c = yy_ch_buf[++yy_c_buf_p]; YY_DO_BEFORE_ACTION; return ( c & BYTEMASK); } :MPW:MPW Tools:Tools with Source:flex ƒ:flexdef.h
/* * Definitions for flex. * * modification history * -------------------- * 02b kg, vp 30sep87 .added definitions for fast scanner; misc. cleanup * 02a vp 27jun86 .translated into C/FTL *//* * Copyright (c) 1987, the University of California * * The United States Government has rights in this work pursuant to * contract no. DE-AC03-76SF00098 between the United States Department of * Energy and the University of California. * * This program may be redistributed. Enhancements and derivative works * may be created provided the new works, if made available to the general * public, are made available for use by anyone. */#include <stdio.h>#ifdef MACINTOSH#include <string.h>#else#ifdef SV#include <string.h>#define bzero(s, n) memset((char *)(s), '\000', (unsigned)(n))#else#include <strings.h>#endif#endif/* Critical where characters are signed. */#ifndef BYTEMASK#define BYTEMASK 0xFF#endif/* Where did THIS come from???char *sprintf();*/char *malloc();char *alloca();char *getenv();#define abs(i) (((i) < 0) ? -(i) : (i))#ifdef MACINTOSH#define bcopy(a,b,c) BlockMove((a),(b),(long)(c))#endif#ifdef MACINTOSH#define EOLCHAR '\r'#else#define EOLCHAR '\n'#endif/* maximum line length we'll have to deal with */#define MAXLINE BUFSIZ/* maximum size of file name */#define FILENAMESIZE 1024#define min(x,y) (x < y ? x : y)#define max(x,y) (x > y ? x : y)#define true 1#define false 0#ifndef DEFAULT_SKELETON_FILE#define DEFAULT_SKELETON_FILE "flex.skel"#endif#ifndef FAST_SKELETON_FILE#define FAST_SKELETON_FILE "flex.fastskel"#endif/* special nxt[] action number for the "at the end of the input buffer" state *//* note: -1 is already taken by YY_NEW_FILE */#define END_OF_BUFFER_ACTION -3/* action number for default action for fast scanners */#define DEFAULT_ACTION -2/* special chk[] values marking the slots taking by end-of-buffer and action * numbers */#define EOB_POSITION -1#define ACTION_POSITION -2/* number of data items per line for -f output */#define NUMDATAITEMS 10/* number of lines of data in -f output before inserting a blank line for * readability. */#define NUMDATALINES 10/* transition_struct_out() definitions */#define TRANS_STRUCT_PRINT_LENGTH 15/* returns true if an nfa state has an epsilon out-transition slot * that can be used. This definition is currently not used. */#define FREE_EPSILON(state) \ (transchar[state] == SYM_EPSILON && \ trans2[state] == NO_TRANSITION && \ finalst[state] != state)/* returns true if an nfa state has an epsilon out-transition character * and both slots are free */#define SUPER_FREE_EPSILON(state) \ (transchar[state] == SYM_EPSILON && \ trans1[state] == NO_TRANSITION) \/* maximum number of NFA states that can comprise a DFA state. It's real * big because if there's a lot of rules, the initial state will have a * huge epsilon closure. */#define INITIAL_MAX_DFA_SIZE 750#define MAX_DFA_SIZE_INCREMENT 750/* array names to be used in generated machine. They're short because * we write out one data statement (which names the array) for each element * in the array. */#define ALIST 'l' /* points to list of rules accepted for a state */#define ACCEPT 'a' /* list of rules accepted for a state */#define ECARRAY 'e' /* maps input characters to equivalence classes */#define MATCHARRAY 'm' /* maps equivalence classes to meta-equivalence classes */#define BASEARRAY 'b' /* "base" array */#define DEFARRAY 'd' /* "default" array */#define NEXTARRAY 'n' /* "next" array */#define CHECKARRAY 'c' /* "check" array *//* NIL must be 0. If not, its special meaning when making equivalence classes * (it marks the representative of a given e.c.) will be unidentifiable */#define NIL 0#define JAM -1 /* to mark a missing DFA transition */#define NO_TRANSITION NIL#define UNIQUE -1 /* marks a symbol as an e.c. representative */#define INFINITY -1 /* for x{5,} constructions *//* size of input alphabet - should be size of ASCII set */#ifdef MACINTOSH#define CSIZE 255#else#define CSIZE 127#endif#define INITIAL_MAXCCLS 100 /* max number of unique character classes */#define MAXCCLS_INCREMENT 100/* size of table holding members of character classes */#define INITIAL_MAX_CCL_TBL_SIZE 500#define MAX_CCL_TBL_SIZE_INCREMENT 250#define INITIAL_MNS 2000 /* default maximum number of nfa states */#define MNS_INCREMENT 1000 /* amount to bump above by if it's not enough */#define INITIAL_MAX_DFAS 1000 /* default maximum number of dfa states */#define MAX_DFAS_INCREMENT 1000#define JAMSTATE -32766 /* marks a reference to the state that always jams *//* enough so that if it's subtracted from an NFA state number, the result * is guaranteed to be negative */#define MARKER_DIFFERENCE 32000#define MAXIMUM_MNS 31999/* maximum number of nxt/chk pairs for non-templates */#define INITIAL_MAX_XPAIRS 2000#define MAX_XPAIRS_INCREMENT 2000/* maximum number of nxt/chk pairs needed for templates */#define INITIAL_MAX_TEMPLATE_XPAIRS 2500#define MAX_TEMPLATE_XPAIRS_INCREMENT 2500#define SYM_EPSILON 0 /* to mark transitions on the symbol epsilon */#define INITIAL_MAX_SCS 40 /* maximum number of start conditions */#define MAX_SCS_INCREMENT 40 /* amount to bump by if it's not enough */#define ONE_STACK_SIZE 500 /* stack of states with only one out-transition */#define SAME_TRANS -1 /* transition is the same as "default" entry for state *//* the following percentages are used to tune table compression: * the percentage the number of out-transitions a state must be of the * number of equivalence classes in order to be considered for table * compaction by using protos */#define PROTO_SIZE_PERCENTAGE 15/* the percentage the number of homogeneous out-transitions of a state * must be of the number of total out-transitions of the state in order * that the state's transition table is first compared with a potential * template of the most common out-transition instead of with the first * proto in the proto queue */#define CHECK_COM_PERCENTAGE 50/* the percentage the number of differences between a state's transition * table and the proto it was first compared with must be of the total * number of out-transitions of the state in order to keep the first * proto as a good match and not search any further */#define FIRST_MATCH_DIFF_PERCENTAGE 10/* the percentage the number of differences between a state's transition * table and the most similar proto must be of the state's total number * of out-transitions to use the proto as an acceptable close match */#define ACCEPTABLE_DIFF_PERCENTAGE 50/* the percentage the number of homogeneous out-transitions of a state * must be of the number of total out-transitions of the state in order * to consider making a template from the state */#define TEMPLATE_SAME_PERCENTAGE 60/* the percentage the number of differences between a state's transition * table and the most similar proto must be of the state's total number * of out-transitions to create a new proto from the state */#define NEW_PROTO_DIFF_PERCENTAGE 20/* the percentage the total number of out-transitions of a state must be * of the number of equivalence classes in order to consider trying to * fit the transition table into "holes" inside the nxt/chk table. */#define INTERIOR_FIT_PERCENTAGE 15/* size of region set aside to cache the complete transition table of * protos on the proto queue to enable quick comparisons */#define PROT_SAVE_SIZE 2000#define MSP 50 /* maximum number of saved protos (protos on the proto queue) *//* maximum number of out-transitions a state can have that we'll rummage * around through the interior of the internal fast table looking for a * spot for it */#define MAX_XTIONS_FOR_FULL_INTERIOR_FIT 4/* number that, if used to subscript an array, has a good chance of producing * an error; should be small enough to fit into a short */#define BAD_SUBSCRIPT -32767/* absolute value of largest number that can be stored in a short, with a * bit of slop thrown in for general paranoia. */#define MAX_SHORT 32766/* Declarations for global variables. *//* variables for symbol tables: * sctbl - start-condition symbol table * ndtbl - name-definition symbol table * ccltab - character class text symbol table */struct hash_entry { struct hash_entry *prev, *next; unsigned char *name; unsigned char *str_val; int int_val; } ;typedef struct hash_entry *hash_table[];#define NAME_TABLE_HASH_SIZE 101#define START_COND_HASH_SIZE 101#define CCL_HASH_SIZE 101extern struct hash_entry *ndtbl[NAME_TABLE_HASH_SIZE]; extern struct hash_entry *sctbl[START_COND_HASH_SIZE];extern struct hash_entry *ccltab[CCL_HASH_SIZE];/* variables for flags: * printstats - if true (-v), dump statistics * syntaxerror - true if a syntax error has been found * eofseen - true if we've seen an eof in the input file * ddebug - if true (-d), make a "debug" scanner * trace - if true (-T), trace processing * spprdflt - if true (-s), suppress the default rule * interactive - if true (-I), generate an interactive scanner * caseins - if true (-i), generate a case-insensitive scanner * useecs - if true (-ce flag), use equivalence classes * fulltbl - if true (-cf flag), don't compress the DFA state table * usemecs - if true (-cm flag), use meta-equivalence classes * reject - if true (-r flag), generate tables for REJECT macro * fullspd - if true (-F flag), use Jacobson method of table representation * gen_line_dirs - if true (i.e., no -L flag), generate #line directives */extern int printstats, syntaxerror, eofseen, ddebug, trace, spprdflt;extern int interactive, caseins, useecs, fulltbl, usemecs, reject;extern int fullspd, gen_line_dirs;/* variables used in the flex input routines: * datapos - characters on current output line * dataline - number of contiguous lines of data in current data * statement. Used to generate readable -f output * skelfile - fd of the skeleton file * yyin - input file * temp_action_file - temporary file to hold actions * action_file_name - name of the temporary file * infilename - name of input file * linenum - current input line number */extern int datapos, dataline, linenum;extern FILE *skelfile, *yyin, *temp_action_file;extern char *infilename;extern char *action_file_name;/* variables for stack of states having only one out-transition: * onestate - state number * onesym - transition symbol * onenext - target state * onedef - default base entry * onesp - stack pointer */#ifdef MALLOC_BUFFERSextern int *onestate,*onesym,*onenext,*onedef,onesp;#elseextern int onestate[ONE_STACK_SIZE], onesym[ONE_STACK_SIZE];extern int onenext[ONE_STACK_SIZE], onedef[ONE_STACK_SIZE], onesp;#endif/* variables for nfa machine data: * current_mns - current maximum on number of NFA states * accnum - number of the last accepting state * firstst - physically the first state of a fragment * lastst - last physical state of fragment * finalst - last logical state of fragment * transchar - transition character * trans1 - transition state * trans2 - 2nd transition state for epsilons * accptnum - accepting number * lastnfa - last nfa state number created */extern int current_mns;extern int accnum, *firstst, *lastst, *finalst, *transchar;extern int *trans1, *trans2, *accptnum, lastnfa;/* variables for protos: * numtemps - number of templates created * numprots - number of protos created * protprev - backlink to a more-recently used proto * protnext - forward link to a less-recently used proto * prottbl - base/def table entry for proto * protcomst - common state of proto * firstprot - number of the most recently used proto * lastprot - number of the least recently used proto * protsave contains the entire state array for protos */#ifdef MALLOC_BUFFERSextern int numtemps, numprots, *protprev, *protnext, *prottbl;extern int *protcomst, firstprot, lastprot,#elseextern int numtemps, numprots, protprev[MSP], protnext[MSP], prottbl[MSP];extern int protcomst[MSP], firstprot, lastprot,#endif#ifdef MALLOC_BUFFERS *protsave;#else protsave[PROT_SAVE_SIZE];#endif/* variables for managing equivalence classes: * numecs - number of equivalence classes * nextecm - forward link of Equivalence Class members * ecgroup - class number or backward link of EC members * nummecs - number of meta-equivalence classes (used to compress * templates) * tecfwd - forward link of meta-equivalence classes members * tecbck - backward link of MEC's */#ifdef MALLOC_BUFFERSextern int numecs, *nextecm, *ecgroup, nummecs;extern int *tecfwd, *tecbck;#elseextern int numecs, nextecm[CSIZE + 1], ecgroup[CSIZE + 1], nummecs;extern int tecfwd[CSIZE + 1], tecbck[CSIZE + 1];#endif/* variables for start conditions: * lastsc - last start condition created * current_max_scs - current limit on number of start conditions * scset - set of rules active in start condition * scbol - set of rules active only at the beginning of line in a s.c. * scxclu - true if start condition is exclusive * actvsc - stack of active start conditions for the current rule */extern int lastsc, current_max_scs, *scset, *scbol, *scxclu, *actvsc;/* variables for dfa machine data: * current_max_dfa_size - current maximum number of NFA states in DFA * current_max_xpairs - current maximum number of non-template xtion pairs * current_max_template_xpairs - current maximum number of template pairs * current_max_dfas - current maximum number DFA states * lastdfa - last dfa state number created * nxt - state to enter upon reading character * chk - check value to see if "nxt" applies * tnxt - internal nxt table for templates * base - offset into "nxt" for given state * def - where to go if "chk" disallows "nxt" entry * tblend - last "nxt/chk" table entry being used * firstfree - first empty entry in "nxt/chk" table * dss - nfa state set for each dfa * dfasiz - size of nfa state set for each dfa * dfaacc - accepting set for each dfa state (or accepting number, if * -r is not given) * accsiz - size of accepting set for each dfa state * dhash - dfa state hash value * todo - queue of DFAs still to be processed * todo_head - head of todo queue * todo_next - next available entry on todo queue * numas - number of DFA accepting states created; note that this * is not necessarily the same value as accnum, which is the analogous * value for the NFA * numsnpairs - number of state/nextstate transition pairs * jambase - position in base/def where the default jam table starts * jamstate - state number corresponding to "jam" state * end_of_buffer_state - end-of-buffer dfa state number */extern int current_max_dfa_size, current_max_xpairs;extern int current_max_template_xpairs, current_max_dfas;extern int lastdfa, lasttemp, *nxt, *chk, *tnxt;extern int *base, *def, tblend, firstfree, **dss, *dfasiz;extern union dfaacc_union { int *dfaacc_set; int dfaacc_state; } *dfaacc;extern int *accsiz, *dhash, *todo, todo_head, todo_next, numas;extern int numsnpairs, jambase, jamstate;extern int end_of_buffer_state;/* variables for ccl information: * lastccl - ccl index of the last created ccl * current_maxccls - current limit on the maximum number of unique ccl's * cclmap - maps a ccl index to its set pointer * ccllen - gives the length of a ccl * cclng - true for a given ccl if the ccl is negated * cclreuse - counts how many times a ccl is re-used * current_max_ccl_tbl_size - current limit on number of characters neededepresent the unique ccl's * ccltbl - holds the characters in each ccl - indexed by cclmap */extern int lastccl, current_maxccls, *cclmap, *ccllen, *cclng, cclreuse;extern int current_max_ccl_tbl_size;extern char *
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:flex ƒ:flexdef.h
+++++ Continued from previous card +++++
ccltbl;/* variables for miscellaneous information: * starttime - real-time when we started * endtime - real-time when we ended * nmstr - last NAME scanned by the scanner * sectnum - section number currently being parsed * nummt - number of empty nxt/chk table entries * hshcol - number of hash collisions detected by snstods * dfaeql - number of times a newly created dfa was equal to an old one * numeps - number of epsilon NFA states created * eps2 - number of epsilon states which have 2 out-transitions * num_reallocs - number of times it was necessary to realloc() a group * of arrays * tmpuses - number of DFA states that chain to templates * totnst - total number of NFA states used to make DFA states * peakpairs - peak number of transition pairs we had to store internally * numuniq - number of unique transitions * numdup - number of duplicate transitions * hshsave - number of hash collisions saved by checking number of states */extern char *starttime, *endtime, nmstr[MAXLINE];extern int sectnum, nummt, hshcol, dfaeql, numeps, eps2, num_reallocs;extern int tmpuses, totnst, peakpairs, numuniq, numdup, hshsave;char *allocate_array(), *reallocate_array();#define allocate_integer_array(size) \ (int *) allocate_array( size, sizeof( int ) )#define reallocate_integer_array(array,size) \ (int *) reallocate_array( (char *) array, size, sizeof( int ) )#define allocate_integer_pointer_array(size) \ (int **) allocate_array( size, sizeof( int * ) )#define allocate_dfaacc_union(size) \ (union dfaacc_union *) \ allocate_array( size, sizeof( union dfaacc_union ) )#define reallocate_integer_pointer_array(array,size) \ (int **) reallocate_array( (char *) array, size, sizeof( int * ) )#define reallocate_dfaacc_union(array, size) \ (union dfaacc_union *) reallocate_array( (char *) array, size, sizeof( union dfaacc_union ) )#define allocate_character_array(size) allocate_array( size, sizeof( char ) )#define reallocate_character_array(array,size) \ reallocate_array( array, size, sizeof( char ) )/* used to communicate between scanner and parser. The type should really * be YYSTYPE, but we can't easily get our hands on it. */extern int yylval; :MPW:MPW Tools:Tools with Source:flex ƒ:flexskelcom.h
/* common macro definitions for C/FTL programs generated by flex *//* Critical where characters are signed. */#define BYTEMASK 0xFF#ifndef EOLCHAR#ifdef MACINTOSH#define EOLCHAR '\r'#else#define EOLCHAR '\n'#endif#endif/* returned upon end-of-file */#define YY_END_TOK 0/* action number for an "end-of-file was seen and yywrap indicated that we * should continue processing" */#define YY_NEW_FILE -1/* action number for "the default action should be done" */#define YY_DO_DEFAULT -2#ifndef BUFSIZ#include <stdio.h>#endif#define YY_BUF_SIZE (BUFSIZ * 2) /* size of input buffer *//* number of characters one rule can match. One less than YY_BUF_SIZE to make * sure we never access beyond the end of an array */#define YY_BUF_MAX (YY_BUF_SIZE - 1)/* we will never use more than the first YY_BUF_LIM + YY_MAX_LINE positions * of the input buffer */#ifndef YY_MAX_LINE#define YY_MAX_LINE BUFSIZ#endif#define YY_BUF_LIM (YY_BUF_MAX - YY_MAX_LINE)/* copy whatever the last rule matched to the standard output */#define ECHO fputs( yytext, yyout )/* gets input and stuffs it into "buf". number of characters read, or YY_NULL, * is returned in "result". */#define YY_INPUT(buf,result,max_size) \ if ( (result = read( fileno(yyin), buf, max_size )) < 0 ) \ YY_FATAL_ERROR( "read() in flex scanner failed" );#define YY_NULL 0/* macro used to output a character */#define YY_OUTPUT(c) putc( c, yyout );/* report a fatal error */#define YY_FATAL_ERROR(msg) \ { \ fputs( msg, stderr ); \ putc( '\n', stderr ); \ exit( 1 ); \ }/* returns the first character of the matched text */#define YY_FIRST_CHAR yy_ch_buf[yy_b_buf_p]/* default yywrap function - always treat EOF as an EOF */#define yywrap() 1/* enter a start condition. This macro really ought to take a parameter, * but we do it the disgusting crufty way that old Unix-lex does it */#define BEGIN yy_start = 1 +/* callable from YY_INPUT to set things up so that '%' will match. Proper * usage is "YY_SET_BOL(array,pos)" */#define YY_SET_BOL(array,pos) array[pos - 1] = EOLCHAR;/* default declaration of generated scanner - a define so the user can * easily add parameters */#define YY_DECL int yylex()/* return all but the first 'n' matched characters back to the input stream */#define yyless(n) \ { \ YY_DO_BEFORE_SCAN; /* undo effects of setting up yytext */ \ yy_c_buf_p = yy_b_buf_p + n - 1; \ YY_DO_BEFORE_ACTION; /* set up yytext again */ \ }/* code executed at the end of each rule */#define YY_BREAK break; :MPW:MPW Tools:Tools with Source:flex ƒ:flexskeldef.h
/* macro definitions for compressed-table C/FTL programs generated by flex */#include "flexskelcom.h"/* reinitializes everything except the current start condition. The last * input character is set to a newline so an initial beginning-of-line * rule will match */#define YY_INIT \ { \ yyleng = yy_c_buf_p = yy_e_buf_p = 0; \ yy_hold_char = yy_ch_buf[yy_c_buf_p] = EOLCHAR; \ yytext = &yy_ch_buf[yy_c_buf_p]; \ yy_saw_eof = 0; \ }/* returns the length of the matched text */#define YY_LENG (yy_c_buf_p - yy_b_buf_p + 1)/* done before the next pattern has been matched action */#define YY_DO_BEFORE_SCAN \ yytext[yyleng] = yy_hold_char;/* done after the current pattern has been matched and before the corresponding action */#define YY_DO_BEFORE_ACTION \ yytext = &yy_ch_buf[yy_b_buf_p]; \ yyleng = YY_LENG; \ yy_hold_char = yytext[yyleng]; \ yytext[yyleng] = '\0';/* find the next rule matched */#ifdef FLEX_REJECT_ENABLED#define REJECT \ { \ YY_DO_BEFORE_SCAN; /* undo effects of setting up yytext */ \ ++yy_lp; \ goto find_rule; \ }#else#define REJECT YY_FATAL_ERROR( "REJECT used and scanner was not generated using -r" )#endif :MPW:MPW Tools:Tools with Source:flex ƒ:flex_environment_variables
# Flex is like lex, only better. set SKELETON_FILE "{clibraries}flex.skel" export SKELETON_FILE set F_SKELETON_FILE "{clibraries}flex.fastskel" export F_SKELETON_FILE alias lex flex# Flex needs these two environment variables defined, also# flexskelcom.h,flexskeldef.h, and fastskeldef.h should be# be put in the C compiler's search path. :MPW:MPW Tools:Tools with Source:flex ƒ:main.c
/* flex - tool to generate fast lexical analyzers * * * Copyright (c) 1987, the University of California * * The United States Government has rights in this work pursuant to * contract no. DE-AC03-76SF00098 between the United States Department of * Energy and the University of California. * * This program may be redistributed. Enhancements and derivative works * may be created provided the new works, if made available to the general * public, are made available for use by anyone. * * * ver date who remarks * --- ---- ------ ------------------------------------------------------- * 04b 30sep87 kg, vp .implemented (part of) Van Jacobson's fast scanner design * 04a 27jun86 vp .translated from Ratfor into C * 01a 22aug83 vp .written. Original version by Jef Poskanzer. */#include "flexdef.h"#ifdef MACINTOSH#undef DEFAULT_SKELETON_FILE#undef FAST_SKELETON_FILE#define DEFAULT_SKELETON_FILE getenv("SKELETON_FILE")#define FAST_SKELETON_FILE getenv("F_SKELETON_FILE")#endif/* these globals are all defined and commented in flexdef.h */int printstats, syntaxerror, eofseen, ddebug, trace, spprdflt;int interactive, caseins, useecs, fulltbl, usemecs, reject;int fullspd, gen_line_dirs;int datapos, dataline, linenum;FILE *skelfile = NULL;char *infilename = NULL;#ifdef MALLOC_BUFFERSint *onestate,*onesym,*onenext,*onedef,onesp;#elseint onestate[ONE_STACK_SIZE], onesym[ONE_STACK_SIZE];int onenext[ONE_STACK_SIZE], onedef[ONE_STACK_SIZE], onesp;#endifint current_mns;int accnum, *firstst, *lastst, *finalst, *transchar;int *trans1, *trans2, *accptnum, lastnfa;#ifdef MALLOC_BUFFERSint numtemps, numprots, *protprev, *protnext, *prottbl;int *protcomst, firstprot, lastprot,#elseint numtemps, numprots, protprev[MSP], protnext[MSP], prottbl[MSP];int protcomst[MSP], firstprot, lastprot,#endif#ifdef MALLOC_BUFFERS *protsave;#else protsave[PROT_SAVE_SIZE];#endif#ifdef MALLOC_BUFFERSint numecs, *nextecm, *ecgroup, nummecs;int *tecfwd, *tecbck;#elseint numecs, nextecm[CSIZE + 1], ecgroup[CSIZE + 1], nummecs;int tecfwd[CSIZE + 1], tecbck[CSIZE + 1];#endifint lastsc, current_max_scs, *scset, *scbol, *scxclu, *actvsc;int current_max_dfa_size, current_max_xpairs;int current_max_template_xpairs, current_max_dfas;int lastdfa, *nxt, *chk, *tnxt;int *base, *def, tblend, firstfree, numtemps, **dss, *dfasiz;union dfaacc_union *dfaacc;int *accsiz, *dhash, *todo, todo_head, todo_next, numas;int numsnpairs, jambase, jamstate;int lastccl, current_maxccls, *cclmap, *ccllen, *cclng, cclreuse;int current_max_ccl_tbl_size;char *ccltbl;char *starttime, *endtime, nmstr[MAXLINE];int sectnum, nummt, hshcol, dfaeql, numeps, eps2, num_reallocs;int tmpuses, totnst, peakpairs, numuniq, numdup, hshsave;FILE *temp_action_file;int end_of_buffer_state;char *action_file_name = "/tmp/flexXXXXXX";/* flex - main program * * synopsis (from the shell) * flex [-v] [file ...] */#ifdef macintosh#pragma segment _other#endifmain( argc, argv )int argc;char **argv; {#ifdef MALLOC_BUFFERS#define GETBUF(a,b) a = (int *)(malloc((b)*sizeof(int))) GETBUF(onestate,ONE_STACK_SIZE); GETBUF(onesym,ONE_STACK_SIZE); GETBUF(onenext,ONE_STACK_SIZE); GETBUF(onedef,ONE_STACK_SIZE); GETBUF(protprev,MSP); GETBUF(protnext,MSP); GETBUF(prottbl,MSP); GETBUF(protcomst,MSP); GETBUF(protsave,PROT_SAVE_SIZE); GETBUF(nextecm,CSIZE + 1); GETBUF(ecgroup,CSIZE + 1); GETBUF(tecfwd,CSIZE + 1); GETBUF(tecbck,CSIZE + 1); if(onestate == NULL || onesym == NULL || onenext == NULL || onedef == NULL || protprev == NULL || protnext == NULL || prottbl == NULL || protcomst == NULL || protsave == NULL || nextecm == NULL || ecgroup == NULL || tecfwd == NULL || tecbck == NULL){ fprintf(stderr,"%s: Out of memory\n",argv[0]); exit(-1); }#endif flexinit( argc, argv ); readin(); if ( ! syntaxerror ) { /* convert the ndfa to a dfa */ ntod(); /* generate the C state transition tables from the DFA */ make_tables(); } /* note, flexend does not return. It exits with its argument as status. */ flexend( 0 ); }/* flexend - terminate flex * * synopsis * int status; * flexend( status ); * * status is exit status. * * note * This routine does not return. */flexend( status )int status; { int tblsiz; char *gettime(); if ( skelfile != NULL ) (void) fclose( skelfile ); if ( temp_action_file ) { (void) fclose( temp_action_file ); (void) unlink( action_file_name ); } if ( printstats ) { endtime = gettime(); fprintf( stderr, "flex usage statistics:\n" ); fprintf( stderr, " started at %s, finished at %s\n", starttime, endtime ); fprintf( stderr, " %d/%d NFA states\n", lastnfa, current_mns ); fprintf( stderr, " %d/%d DFA states (%d words)\n", lastdfa, current_max_dfas, totnst ); fprintf( stderr, " %d rules\n", accnum ); fprintf( stderr, " %d/%d start conditions\n", lastsc, current_max_scs ); fprintf( stderr, " %d epsilon states, %d double epsilon states\n", numeps, eps2 ); if ( lastccl == 0 ) fprintf( stderr, " no character classes\n" ); else fprintf( stderr, " %d/%d character classes needed %d/%d words of storage, %d reused\n", lastccl, current_maxccls, cclmap[lastccl] + ccllen[lastccl] - 1, current_max_ccl_tbl_size, cclreuse ); fprintf( stderr, " %d state/nextstate pairs created\n", numsnpairs ); fprintf( stderr, " %d/%d unique/duplicate transitions\n", numuniq, numdup ); if ( fulltbl ) { tblsiz = lastdfa * numecs; fprintf( stderr, " %d table entries\n", tblsiz ); } else { tblsiz = 2 * (lastdfa + numtemps) + 2 * tblend; fprintf( stderr, " %d/%d base/def entries created\n", lastdfa + numtemps, current_max_dfas ); fprintf( stderr, " %d/%d (peak %d) nxt/chk entries created\n", tblend, current_max_xpairs, peakpairs ); fprintf( stderr, " %d/%d (peak %d) template nxt/chk entries created\n", numtemps * nummecs, current_max_template_xpairs, numtemps * numecs ); fprintf( stderr, " %d empty table entries\n", nummt ); fprintf( stderr, " %d protos created\n", numprots ); fprintf( stderr, " %d templates created, %d uses\n", numtemps, tmpuses ); } if ( useecs ) { tblsiz = tblsiz + CSIZE; fprintf( stderr, " %d/%d equivalence classes created\n", numecs, CSIZE ); } if ( usemecs ) { tblsiz = tblsiz + numecs; fprintf( stderr, " %d/%d meta-equivalence classes created\n", nummecs, CSIZE ); } fprintf( stderr, " %d (%d saved) hash collisions, %d DFAs equal\n", hshcol, hshsave, dfaeql ); fprintf( stderr, " %d sets of reallocations needed\n", num_reallocs ); fprintf( stderr, " %d total table entries needed\n", tblsiz ); } exit( status ); }/* flexinit - initialize flex * * synopsis * int argc; * char **argv; * flexinit( argc, argv ); */flexinit( argc, argv )int argc;char **argv; { int i, sawcmpflag, use_stdout; char *arg, *skelname = NULL, *gettime(), clower(), *mktemp(); printstats = syntaxerror = trace = spprdflt = interactive = caseins = false; ddebug = fulltbl = reject = fullspd = false; gen_line_dirs = usemecs = useecs = true; sawcmpflag = false; use_stdout = false; /* read flags */ for ( --argc, ++argv; argc ; --argc, ++argv ) { if ( argv[0][0] != '-' || argv[0][1] == '\0' ) break; arg = argv[0]; for ( i = 1; arg[i] != '\0'; ++i ) switch ( arg[i] ) { case 'c': if ( i != 1 ) flexerror( "-c flag must be given separately" ); if ( ! sawcmpflag ) { useecs = false; usemecs = false; fulltbl = false; sawcmpflag = true; } for ( ++i; arg[i] != '\0'; ++i ) switch ( clower( arg[i] ) ) { case 'e': useecs = true; break; case 'F': fullspd = true; break; case 'f': fulltbl = true; break; case 'm': usemecs = true; break; default: lerrif( "unknown -c option %c", (int) arg[i] ); break; } goto get_next_arg; case 'd': ddebug = true; break; case 'f': useecs = usemecs = false; fulltbl = true; break; case 'I': interactive = true; break; case 'i': caseins = true; break; case 'L': gen_line_dirs = false; break; case 'r': reject = true; break; case 'F': useecs = usemecs = false; fullspd = true; break; case 'S': if ( i != 1 ) flexerror( "-S flag must be given separately" ); skelname = arg + i + 1; goto get_next_arg; case 's': spprdflt = true; break; case 't': use_stdout = true; break; case 'T': trace = true; break; case 'v': printstats = true; break; default: lerrif( "unknown flag %c", (int) arg[i] ); break; }get_next_arg: /* used by -c and -S flags in lieu of a "continue 2" control */ ; } if ( (fulltbl || fullspd) && usemecs ) flexerror( "full table and -cm don't make sense together" ); if ( (fulltbl || fullspd) && interactive ) flexerror( "full table and -I are (currently) incompatible" ); if ( (fulltbl || fullspd) && reject ) flexerror( "reject (-r) cannot be used with -f or -F" ); if ( fulltbl && fullspd ) flexerror( "full table and -F are mutually exclusive" ); if ( ! skelname ) { static char skeleton_name_storage[400]; skelname = skeleton_name_storage; if ( fullspd || fulltbl ) (void) strcpy( skelname, FAST_SKELETON_FILE ); else (void) strcpy( skelname, DEFAULT_SKELETON_FILE ); } if ( ! use_stdout ) { FILE *prev_stdout = freopen( "lex.yy.c", "w", stdout ); if ( prev_stdout == NULL ) flexerror( "could not create lex.yy.c" ); } if ( argc ) { if ( argc > 1 ) flexerror( "extraneous argument(s) given" ); yyin = fopen( infilename = argv[0], "r" ); if ( yyin == NULL ) lerrsf( "can't open %s", argv[0] ); } else yyin = stdin; lastccl = 0; lastsc = 0; /* initialize the statistics */ starttime = gettime(); if ( (skelfile = fopen( skelname, "r" )) == NULL ) lerrsf( "can't open skeleton file %s", skelname );#ifndef MACINTOSH /* Single-user system. */ (void) mktemp( action_file_name );#endif if ( (temp_action_file = fopen( action_file_name, "w" )) == NULL ) lerrsf( "can't open temporary action file %s", action_file_name ); lastdfa = lastnfa = accnum = numas = numsnpairs = tmpuses = 0; numecs = numeps = eps2 = num_reallocs = hshcol = dfaeql = totnst = 0; numuniq = numdup = hshsave = eofseen = datapos = dataline = 0; onesp = numprots = 0; linenum = sectnum = 1; firstprot = NIL; /* used in mkprot() so that the first proto goes in slot 1 * of the proto queue */ lastprot = 1; if ( useecs ) { /* set up doubly-linked equivalence classes */ ecgroup[1] = NIL; for ( i = 2; i <= CSIZE; ++i ) { ecgroup[i] = i - 1; nextecm[i - 1] = i; } nextecm[CSIZE] = NIL; } else { /* put everything in its own equivalence class */ for ( i = 1; i <= CSIZE; ++i ) { ecgroup[i] = i; nextecm[i] = BAD_SUBSCRIPT; /* to catch errors */ } } set_up_initial_allocations(); }/* readin - read in the rules section of the input file(s) * * synopsis * readin(); */readin() { fputs( "#define YY_DEFAULT_ACTION ", stdout ); if ( spprdflt ) fputs( "YY_FATAL_ERROR( \"flex scanner jammed\" )", stdout ); else fputs( "ECHO", stdout ); fputs( ";\n", stdout ); if ( ddebug ) puts( "#define FLEX_DEBUG" ); if ( useecs ) puts( "#define FLEX_USE_ECS" ); if ( usemecs ) puts( "#define FLEX_USE_MECS" ); if ( interactive ) puts( "#define FLEX_INTERACTIVE_SCANNER" ); if ( reject ) puts( "#define FLEX_REJECT_ENABLED" ); if ( fulltbl ) puts( "#define FLEX_FULL_TABLE" ); skelout(); line_directive_out( stdout ); if ( yyparse() )#ifdef MACINTOSH /* See tool interface guidelines in MPW manual. */ { char panicmsg[128]; sprintf(panicmsg,"File %s ; %%d # Fatal parse error."); lerrif(panicmsg,linenum); }#else lerrif( "fatal parse error at line %d", linenum );#endif if ( useecs ) { numecs = cre8ecs( nextecm, ecgroup, CSIZE ); ccl2ecl(); } else numecs = CSIZE; }/* set_up_initial_allocations - allocate memory for internal tables */set_up_initial_allocations() { current_mns = INITIAL_MNS; firstst = allocate_integer_array( current_mns ); lastst = allocate_integer_array( current_mns ); finalst = allocate_integer_array( current_mns ); transchar = allocate_integer_array( current_mns ); trans1 = allocate_integer_array( current_mns ); trans2 = allocate_integer_array( current_mns ); accptnum = allocate_integer_array( current_mns ); current_max_scs = INITIAL_MAX_SCS; scset = allocate_integer_array( current_max_scs ); scbol = allocate_integer_array( current_max_scs ); scxclu = allocate_integer_array( current_max_scs ); actvsc = allocate_integer_array( current_max_scs ); current_maxccls = INITIAL_MAXCCLS; cclmap = allocate_integer_array( current_maxccls ); ccllen = allocate_integer_array( current_maxccls ); cclng = allocate_integer_array( current_maxccls ); current_max_ccl_tbl_size = INITIAL_MAX_CCL_TBL_SIZE; ccltbl = allocate_character_array( current_max_ccl_tbl_size ); current_max_dfa_size = INITIAL_MAX_DFA_SIZE; current_max_xpairs = INITIAL_MAX_XPAIRS; nxt = allocate_integer_array( current_max_xpairs ); chk = allocate_integer_array( current_max_xpairs ); current_max_template_xpairs = INITIAL_MAX_TEMPLATE_XPAIRS; tnxt = allocate_integer_array( current_max_template_xpairs ); current_max_dfas = INITIAL_MAX_DFAS; base = allocate_integer_array( current_max_dfas ); def = allocate_integer_array( current_max_dfas ); dfasiz = allocate_integer_array( current_max_dfas ); accsiz = allocate_integer_array( current_max_dfas ); dhash = allocate_integer_array( current_max_dfas ); todo = allocate_integer_array( current_max_dfas ); dss = allocate_integer_pointer_array( current_max_dfas ); dfaacc = allocate_dfaacc_union( current_max_dfas ); } :MPW:MPW Tools:Tools with Source:flex ƒ:makefile.aztec
# make file for "flex" tool# MPW make version for Aztec C 3.6c by Earle Horton, May 1988# the first time around use "make first_flex"INCLUDES = "{include}"BINDIR = "{MPW}"Tools:LIBDIR = "{clib}"SKELETON_FILE_NAME = getenv(∂"SKELETON_FILE∂")F_SKELETON_FILE_NAME = getenv(∂"F_SKELETON_FILE∂")SKELFLAGS = -DDEFAULT_SKELETON_FILE={SKELETON_FILE_NAME} ∂ -DFAST_SKELETON_FILE={F_SKELETON_FILE_NAME}CFLAGS = --N -DMACINTOSH -DMALLOC_BUFFERS -A -y 800 -e 600LDFLAGS = -lmpw -lshcroot -lc .o ƒ .c Cc {default}.c {CFLAGS} -o {default}.asm -A as {default}.asm -o {default}.o -ZAPFLEX_FLAGS = -istFLEX = flexFLEXOBJS = ∂ alloca.o ∂ bzero.o ∂ ccl.o ∂ dfa.o ∂ ecs.o ∂ main.o ∂ misc.o ∂ nfa.o ∂ parse.o ∂ scan.o ∂ sym.o ∂ tblcmp.o ∂ yylex.oFLEX_C_SOURCES = ∂ bzero.c ∂ ccl.c ∂ dfa.c ∂ ecs.c ∂ main.c ∂ misc.c ∂ nfa.c ∂ parse.c ∂ scan.c ∂ sym.c ∂ tblcmp.c ∂ yylex.cflex ƒ {FLEXOBJS} ln -o flex {FLEXOBJS} {LDFLAGS} delete -i ctmpfirst_flex ƒ duplicate scan.c.dist scan.c make {MFLAGS} flexparse.c ƒ parse.y yacc -d parse.y move -y y.tab.c parse.c move -y y.tab.h parse.hparse.h ƒ parse.c# comment-out the next two lines after a successful "make test" and# comment-in the following two lines.alloca.o ƒ alloca.s as alloca.s -o alloca.oscan.c ƒ scan.l {FLEX} {FLEX_FLAGS} scan.l >scan.cscan.o ƒ scan.c parse.c# Anybody have lint?flex.lint ƒ {FLEX_C_SOURCES} echo "Expect a ∂"may be used before set∂" and 2 ∂"unused∂"'s lint {FLEX_C_SOURCES} > flex.lintclean ƒ delete -i flex ≈.o parse.c parse.h scan.ctest ƒ echo "This step destroys junk.c." {FLEX} {FLEX_FLAGS} scan.l > junk.c compare scan.c junk.c delete junk.cinstall ƒ {FLEX} duplicate -y {FLEX} {BINDIR} duplicate -y flexskelcom.h {INCLUDES} duplicate -y flexskeldef.h {INCLUDES} duplicate -y fastskeldef.h {INCLUDES} duplicate -y flex.skel {LIBDIR} duplicate -y flex.fastskel {LIBDIR} :MPW:MPW Tools:Tools with Source:flex ƒ:makefile.mpw
# make file for "flex" tool# MPW make version by Earle Horton, May 1988# the first time around use "make first_flex"INCLUDES = "{cincludes}"BINDIR = "{MPW}"Tools:LIBDIR = "{clibraries}"SKELETON_FILE_NAME = getenv(∂"SKELETON_FILE∂")F_SKELETON_FILE_NAME = getenv(∂"F_SKELETON_FILE∂")SKELFLAGS = -d DEFAULT_SKELETON_FILE={SKELETON_FILE_NAME} ∂ -d FAST_SKELETON_FILE={F_SKELETON_FILE_NAME}CFLAGS = -m -d MPU68000 -d macintosh -d malloc_buffersC = "{MPW}"tools:cLDFLAGS = -ss 80000 -d -c 'MPS ' -t MPST ∂ "{Libraries}"stubs.o ∂ "{CLibraries}"CRuntime.o ∂ "{CLibraries}"StdCLib.o ∂ "{CLibraries}"CInterface.o ∂ "{Libraries}"Interface.o .c.o ƒ .c {C} {default}.c {CFLAGS} -o {default}.c.oFLEX_FLAGS = -istFLEX = flexFLEXOBJS = ∂ alloca.a.o ∂ bzero.c.o ∂ ccl.c.o ∂ dfa.c.o ∂ ecs.c.o ∂ main.c.o ∂ misc.c.o ∂ nfa.c.o ∂ parse.c.o ∂ scan.c.o ∂ sym.c.o ∂ tblcmp.c.o ∂ yylex.c.oFLEX_C_SOURCES = ∂ bzero.c ∂ ccl.c ∂ dfa.c ∂ ecs.c ∂ main.c ∂ misc.c ∂ nfa.c ∂ parse.c ∂ scan.c ∂ sym.c ∂ tblcmp.c ∂ yylex.cflex ƒ {FLEXOBJS} Link -o flex {FLEXOBJS} {LDFLAGS}first_flex ƒ duplicate scan.c.dist scan.c make {MFLAGS} flex parse.c ƒ parse.y bison -d parse.y move -y parse.tab.c parse.c move -y parse.tab.h parse.hparse.h ƒ parse.c# comment-out the next two lines after a successful "make test" and# comment-in the following two lines.# scan.c ƒ scan.l# {FLEX} {FLEX_FLAGS} scan.l >scan.cscan.c.o ƒ scan.c parse.hmain.c.o ƒ main.c {C} {CFLAGS} {SKELFLAGS} main.c# Anybody have lint?flex.lint ƒ {FLEX_C_SOURCES} echo "Expect a ∂"may be used before set∂" and 2 ∂"unused∂"'s lint {FLEX_C_SOURCES} > flex.lintclean ƒ delete -i flex ≈.o parse.c parse.h scan.ctest ƒ echo "This step destroys junk.c." {FLEX} {FLEX_FLAGS} scan.l > junk.c compare scan.c junk.c delete junk.cinstall ƒ {FLEX} duplicate -y "{FLEX}" "{BINDIR}" duplicate -y flexskelcom.h "{INCLUDES}" duplicate -y flexskeldef.h "{INCLUDES}" duplicate -y fastskeldef.h "{INCLUDES}" duplicate -y flex.skel "{LIBDIR}" duplicate -y flex.fastskel "{LIBDIR}" :MPW:MPW Tools:Tools with Source:flex ƒ:makefile.UNIX
# make file for "flex" tool# the first time around use "make first_flex"SKELETON_FILE = \"/usr/local/lib/flex.skel\"F_SKELETON_FILE = \"/usr/local/lib/flex.fastskel\"SKELFLAGS = -DDEFAULT_SKELETON_FILE=$(SKELETON_FILE) \ -DFAST_SKELETON_FILE=$(F_SKELETON_FILE)CC = cCFLAGS = '+L' '+D'LDFLAGS =FLEX_FLAGS = -istFLEX = flexFLEXOBJS = \ ccl.o \ dfa.o \ ecs.o \ main.o \ misc.o \ nfa.o \ parse.o \ scan.o \ sym.o \ tblcmp.o \ yylex.oFLEX_C_SOURCES = \ ccl.c \ dfa.c \ ecs.c \ main.c \ misc.c \ nfa.c \ parse.c \ scan.c \ sym.c \ tblcmp.c \ yylex.cflex : $(FLEXOBJS) cc $(CFLAGS) -o flex $(LDFLAGS) $(FLEXOBJS)first_flex: cp scan.c.dist scan.c make $(MFLAGS) flexparse.h parse.c : parse.y yacc -d parse.y @mv y.tab.c parse.c @mv y.tab.h parse.h# comment-out the next two lines after a successful "make test" and# comment-in the following two lines.scan.c : scan.l $(FLEX) $(FLEX_FLAGS) scan.l >scan.cscan.o : scan.c parse.hmain.o : main.c cc $(CFLAGS) -c $(SKELFLAGS) main.cflex.lint : $(FLEX_C_SOURCES) @echo "Expect a \"may be used before set\" and 2 \"unused\"'s lint $(FLEX_C_SOURCES) > flex.lintclean : rm -f core errs flex *.o parse.c *.lint parse.htest : $(FLEX) $(FLEX_FLAGS) scan.l | diff scan.c - :MPW:MPW Tools:Tools with Source:flex ƒ:manifest
Name --------alloca.a bzero.c ccl.cChangesdfa.cecs.cfastskeldef.hflex.1flex.fastskelflex.man.pageflex.skelflexdef.hflexit flexskelcom.h flexskeldef.hmain.cmakefile.MPWmakefile.UNIXmanifestmisc.cnfa.cparse.yREADMEREADME_for_Macintoshscan.c.distscan.lsym.ctblcmp.cTimingsyylex.c :MPW:MPW Tools:Tools with Source:flex ƒ:misc.c
/* misc - miscellaneous flex routines *//* * Copyright (c) 1987, the University of California * * The United States Government has rights in this work pursuant to * contract no. DE-AC03-76SF00098 between the United States Department of * Energy and the University of California. * * This program may be redistributed. Enhancements and derivative works * may be created provided the new works, if made available to the general * public, are made available for use by anyone. */#include <ctype.h>#include "flexdef.h"#ifdef macintosh#pragma segment _other#endifchar *malloc(), *realloc();/* action_out - write the actions from the temporary file to lex.yy.c * * synopsis * action_out(); * * Copies the action file up to %% (or end-of-file) to lex.yy.c */action_out() { char buf[MAXLINE]; while ( fgets( buf, MAXLINE, temp_action_file ) != NULL ) if ( buf[0] == '%' && buf[1] == '%' ) break; else fputs( buf, stdout ); }/* allocate_array - allocate memory for an integer array of the given size */char *allocate_array( size, element_size )int size, element_size; { register char *mem = malloc( (unsigned) (element_size * size) ); if ( mem == NUexfatal( "memory allocation failed in allocate_array()" ); return ( mem ); }/* bubble - bubble sort an integer array in increasing order * * synopsis * int v[n], n; * bubble( v, n ); * * description * sorts the first n elements of array v and replaces them in * increasing order. * * passed * v - the array to be sorted * n - the number of elements of 'v' to be sorted */bubble( v, n )int v[], n; { register int i, j, k; for ( i = n; i > 1; --i ) for ( j = 1; j < i; ++j ) if ( v[j] > v[j + 1] ) /* compare */ { k = v[j]; /* exchange */ v[j] = v[j + 1]; v[j + 1] = k; } }/* clower - replace upper-case letter to lower-case * * synopsis: * char clower(), c; * c = clower( c ); */char clower( c )register char c; { return ( isupper(c) ? tolower(c) : c ); }/* copy_string - returns a dynamically allocated copy of a string * * synopsis * char *str, *copy, *copy_string(); * copy = copy_string( str ); */char *copy_string( str )register char *str; { register char *c; char *copy; /* find length */ for ( c = str; *c; ++c ) ; copy = malloc( (unsigned) ((c - str + 1) * sizeof( char )) ); if ( copy == NULL ) flexfatal( "dynamic memory failure in copy_string()" ); for ( c = copy; (*c++ = *str++); ) ; return ( copy ); }/* cshell - shell sort a character array in increasing order * * synopsis * * char v[n]; * int n; * cshell( v, n ); * * description * does a shell sort of the first n elements of array v. * * passed * v - array to be sorted * n - number of elements of v to be sorted */cshell( v, n )char v[];int n; { int gap, i, j, jg; char k; for ( gap = n / 2; gap > 0; gap = gap / 2 ) for ( i = gap; i < n; ++i ) for ( j = i - gap; j >= 0; j = j - gap ) { jg = j + gap; if ( v[j] <= v[jg] ) break; k = v[j]; v[j] = v[jg]; v[jg] = k; } }/* dataend - finish up a block of data declarations * * synopsis * dataend(); */dataend() { if ( datapos > 0 ) dataflush(); /* add terminator for initialization */ puts( " } ;\n" ); dataline = 0; }/* dataflush - flush generated data statements * * synopsis * dataflush(); lush() { putchar( '\n' ); if ( ++dataline >= NUMDATALINES ) { /* put out a blank line so that the table is grouped into * large blocks that enable the user to find elements easily */ putchar( '\n' ); dataline = 0; } /* reset the number of characters written on the current line */ datapos = 0; }/* gettime - return current time * * synopsis * char *gettime(), *time_str; * time_str = gettime(); */#ifdef MACINTOSH#ifdef macintoshvoid iutimestring(long dateTime,unsigned char wantSeconds,char *result); #endif#endif#ifdef MPU68000char *gettime() { char *copy_string(); long curtime; char strbuf[256]; GETDATETIME(&curtime); iutimestring(curtime,0xFFFF,strbuf); p2cstr(strbuf); return (copy_string(strbuf));}#else/* include sys/types.h to use time_t and make lint happy */#include <sys/types.h>char *gettime() { time_t t, time(); char *result, *ctime(), *copy_string(); t = time( (long *) 0 ); result = copy_string( ctime( &t ) ); /* get rid of trailing newline */ result[24] = '\0'; return ( result ); }#endif/* lerrif - report an error message formatted with one integer argument * * synopsis * char msg[]; * int arg; * lerrif( msg, arg ); */lerrif( msg, arg )char msg[];int arg; { char errmsg[MAXLINE]; (void) sprintf( errmsg, msg, arg ); flexerror( errmsg ); }/* lerrsf - report an error message formatted with one string argument * * synopsis * char msg[], arg[]; * lerrsf( msg, arg ); */lerrsf( msg, arg )char msg[], arg[]; { char errmsg[MAXLINE]; (void) sprintf( errmsg, msg, arg ); flexerror( errmsg ); }/* flexerror - report an error message and terminate * * synopsis * char msg[]; * flexerror( msg ); */flexerror( msg )char msg[]; { fprintf( stderr, "flex: %s\n", msg ); flexend( 1 ); }/* flexfatal - report a fatal error message and terminate * * synopsis * char msg[]; * flexfatal( msg ); */flexfatal( msg )char msg[]; { fprintf( stderr, "flex: fatal internal error %s\n", msg ); flexend( 1 ); }/* line_directive_out - spit out a "# line" statement */line_directive_out( output_file_name )FILE *output_file_name; { if ( infilename && gen_line_dirs ) fprintf( output_file_name, "# line %d \"%s\"\n", linenum, infilename ); }/* mk2data - generate a data statement for a two-dimensional array * * synopsis * int value; * mk2data( value ); * * generates a data statement initializing the current 2-D array to "value" */mk2data( value )int value; { if ( datapos >= NUMDATAITEMS ) { putchar( ',' ); dataflush(); } if ( datapos == 0 ) /* indent */ fputs( " ", stdout ); else putchar( ',' ); ++datapos; printf( "%5d", value ); }/* mkdata - generate a data statement * * synopsis * int value; * mkdata( value ); * * generates a data statement initializing the current array element to * "value" */mkdata( value )int value; { if ( datapos >= NUMDATAITEMS ) { putchar( ',' ); dataflush(); } if ( datapos == 0 ) /* indent */ fputs( " ", stdout ); else putchar( ',' ); ++datapos; printf( "%5d", value ); }/* myctoi - return the integer represented by a string of digits * * synopsis * char array[]; * int val, myctoi(); * val = myctoi( array ); * */int myctoi( array )char array[]; { int val = 0; (void) sscanf( array, "%d", &val ); return ( val ); }/* myesc - return character corresponding to escape sequence * * synopsis * char array[], c, myesc(); * c = myesc( array ); * */char myesc( array )char array[]; { switch ( array[1] ) { case 'n': return ( EOLCHAR ); case 't': return ( '\t' ); case 'f': return ( '\f' ); case 'r': return ( '\r' ); case 'b': return ( '\b' ); case '0': if ( isdigit(array[2]) ) { /* \0<octal> */ char c, esc_char; register int sptr = 2; while ( isdigit(array[sptr]) ) /* don't increment inside loop control because the * macro will expand it to two increments! (Not a * problem with the C version of the macro) */ ++sptr; c = array[sptr]; array[sptr] = '\0'; esc_char = otoi( array + 2 ); array[sptr] = c; if ( esc_char == '\0' ) { synerr( "escape sequence for null not allowed" ); return ( 1 ); } return ( esc_char ); } else { synerr( "escape sequence for null not allowed" ); return ( 1 ); }#ifdef NOTDEF case '^': { register char next_char = array[2]; if ( next_char == '?' ) return ( 0x7f ); else if ( next_char >= 'A' && next_char <= 'Z' ) return ( next_char - 'A' + 1 ); else if ( next_char >= 'a' && next_char <= 'z' ) return ( next_char - 'z' + 1 ); synerr( "illegal \\^ escape sequence" ); return ( 1 ); }#endif } return ( array[1] ); }/* otoi - convert an octal digit string to an integer value * * synopsis: * int val, otoi(); * char str[]; * val = otoi( str ); */int otoi( str )char str[]; {#ifdef FTLSOURCE fortran int gctoi() int dummy = 1; return ( gctoi( str, dummy, 8 ) );#else int result; (void) sscanf( str, "%o", &result ); return ( result );#endif }/* reallocate_array - increase the size of a dynamic array */char *reallocate_array( array, size, element_size )char *array;int size, element_size; { register char *new_array = realloc( array, (unsigned) (size * element_size )); if ( new_array == NULL ) flexfatal( "attempt to increase array size failed" ); return ( new_array ); }/* skelout - write out one section of the skeleton file * * synopsis * skelout(); * * DESCRIPTION * Copies from skelfile to stdout until a line beginning with "%%" or * EOF is found. */skelout() { char buf[MAXLINE]; while ( fgets( buf, MAXLINE, skelfile ) != NULL ) if ( buf[0] == '%' && buf[1] == '%' ) break; else fputs( buf, stdout ); }/* transition_struct_out - output a yy_trans_info structure * * synopsis * int element_v, element_n; * transition_struct_out( element_v, element_n ); * * outputs the yy_trans_info structure with the two elements, element_v and * element_n. Formats the output with spaces and carriage returns. */transition_struct_out( element_v, element_n )int element_v, element_n; { printf( "%7d, %5d,", element_v, element_n ); datapos += TRANS_STRUCT_PRINT_LENGTH; if ( datapos >= 75 ) { printf( "\n" ); if ( ++dataline % 10 == 0 ) printf( "\n" ); datapos = 0; } } :MPW:MPW Tools:Tools with Source:flex ƒ:nfa.c
/* nfa - NFA construction routines *//* * Copyright (c) 1987, the University of California * * The United States Government has rights in this work pursuant to * contract no. DE-AC03-76SF00098 between the United States Department of * Energy and the University of California. * * This program may be redistributed. Enhancements and derivative works * may be created provided the new works, if made available to the general * public, are made available for use by anyone. */#include "flexdef.h"/* add_accept - add an accepting state to a machine * * synopsis * * add_accept( mach, headcnt, trailcnt ); * * the global ACCNUM is incremented and the new value becomes mach's * accepting number. if headcnt or trailcnt is non-zero then the machine * recognizes a pattern with trailing context. headcnt is the number of * characters in the matched part of the pattern, or zero if the matched * part has variable length. trailcnt is the number of trailing context * characters in the pattern, or zero if the trailing context has variable * length. */add_accept( mach, headcnt, trailcnt )int mach, headcnt, trailcnt; { int astate; fprintf( temp_action_file, "case %d:\n", ++accnum ); if ( headcnt > 0 || trailcnt > 0 ) { /* do trailing context magic to not match the trailing characters */ fprintf( temp_action_file, "YY_DO_BEFORE_SCAN; /* undo effects of setting up yytext */\n" ); if ( headcnt > 0 ) { int head_offset = headcnt - 1; if ( fullspd || fulltbl ) /* with the fast skeleton, yy_c_buf_p points to the *next* * character to scan, rather than the one that was last * scanned */ ++head_offset; if ( head_offset > 0 ) fprintf( temp_action_file, "yy_c_buf_p = yy_b_buf_p + %d;\n", head_offset ); else fprintf( temp_action_file, "yy_c_buf_p = yy_b_buf_p;\n" ); } else fprintf( temp_action_file, "yy_c_buf_p -= %d;\n", trailcnt ); fprintf( temp_action_file, "YY_DO_BEFORE_ACTION; /* set up yytext again */\n" ); } line_directive_out( temp_action_file ); /* hang the accepting number off an epsilon state. if it is associated * with a state that has a non-epsilon out-transition, then the state * will accept BEFORE it makes that transition, i.e., one character * too soon */ if ( transchar[finalst[mach]] == SYM_EPSILON ) accptnum[finalst[mach]] = accnum; else { astate = mkstate( SYM_EPSILON ); accptnum[astate] = accnum; mach = link_machines( mach, astate ); } }/* copysingl - make a given number of copies of a singleton machine * * synopsis * * newsng = copysingl( singl, num ); * * newsng - a new singleton composed of num copies of singl * singl - a singleton machine * num - the number of copies of singl to be present in newsng */int copysingl( singl, num )int singl, num; { int copy, i; copy = mkstate( SYM_EPSILON ); for ( i = 1; i <= num; ++i ) copy = link_machines( copy, dupmachine( singl ) ); return ( copy ); }/* dumpnfa - debugging routine to write out an nfa * * synopsis * int state1; * dumpnfa( state1 ); */dumpnfa( state1 )int state1; { int sym, tsp1, tsp2, anum, ns; fprintf( stderr, "\n\n********** beginning dump of nfa with start state %d\n", state1 ); /* we probably should loop starting at firstst[state1] and going to * lastst[state1], but they're not maintained properly when we "or" * all of the rules together. So we use our knowledge that the machine * starts at state 1 and ends at lastnfa. */ /* for ( ns = firstst[state1]; ns <= lastst[state1]; ++ns ) */ for ( ns = 1; ns <= lastnfa; ++ns ) { fprintf( stderr, "state # %4d\t", ns ); sym = transchar[ns]; tsp1 = trans1[ns]; tsp2 = trans2[ns]; anum = accptnum[ns]; fprintf( stderr, "%3d: %4d, %4d", sym, tsp1, tsp2 ); if ( anum != NIL ) fprintf( stderr, " [%d]", anum ); fprintf( stderr, "\n" ); } fprintf( stderr, "********** end of dump\n" ); }/* dupmachine - make a duplicate of a given machine * * synopsis * * copy = dupmachine( mach ); * * copy - holds duplicate of mach * mach - machine to be duplicated * * note that the copy of mach is NOT an exact duplicate; rather, all the * transition states values are adjusted so that the copy is self-contained, * as the original should have been. * * also note that the original MUST be contiguous, with its low and high * states accessible by the arrays firstst and lastst */int dupmachine( mach )int mach; { int i, state, init, last = lastst[mach], state_offset; for ( i = firstst[mach]; i <= last; ++i ) { state = mkstate( transchar[i] ); if ( trans1[i] != NO_TRANSITION ) { mkxtion( finalst[state], trans1[i] + state - i ); if ( transchar[i] == SYM_EPSILON && trans2[i] != NO_TRANSITION ) mkxtion( finalst[state], trans2[i] + state - i ); } accptnum[state] = accptnum[i]; } state_offset = state - i + 1; init = mach + state_offset; firstst[init] = firstst[mach] + state_offset; finalst[init] = finalst[mach] + state_offset; lastst[init] = lastst[mach] + state_offset; return ( init ); }/* link_machines - connect two machines together * * synopsis * * new = link_machines( first, last ); * * new - a machine constructed by connecting first to last * first - the machine whose successor is to be last * last - the machine whose predecessor is to be first * * note: this routine concatenates the machine first with the machine * last to produce a machine new which will pattern-match first first * and then last, and will fail if either of the sub-patterns fails. * FIRST is set to new by the operation. last is unmolested. */int link_machines( first, last )int first, last; { if ( first == NIL ) return ( last ); else if ( last == NIL ) return ( first ); else { mkxtion( finalst[first], last ); finalst[first] = finalst[last]; lastst[first] = max( lastst[first], lastst[last] ); firstst[first] = min( firstst[first], firstst[last] ); return ( first ); } }/* mkbranch - make a machine that branches to two machines * * synopsis * * branch = mkbranch( first, second ); * * branch - a machine which matches either first's pattern or second's * first, second - machines whose patterns are to be or'ed (the | operator) * * note that first and second are NEITHER destroyed by the operation. Also, * the resulting machine CANNOT be used with any other "mk" operation except * more mkbranch's. Compare with mkor() */int mkbranch( first, second )int first, second; { int eps; if ( first == NO_TRANSITION ) return ( second ); else if ( second == NO_TRANSITION ) return ( first ); eps = mkstate( SYM_EPSILON ); mkxtion( eps, first ); mkxtion( eps, second ); return ( eps ); }/* mkclos - convert a machine into a closure * * synopsis * new = mkclos( state ); * * new - a new state which matches the closure of "state" */int mkclos( state )int state; { return ( mkopt( mkposcl( state ) ) ); }/* mkopt - make a machine optional * * synopsis * * new = mkopt( mach ); * * new - a machine which optionally matches whatever mach matched * mach - the machine to make optional * * notes: * 1. mach must be the last machine created * 2. mach is destroyed by the call */int mkopt( mach )int mach; { int eps; if ( ! SUPER_FREE_EPSILON(finalst[mach]) ) { eps = mkstate( SYM_EPSILON ); mach = link_machines( mach, eps ); } /* can't skimp on the following if FREE_EPSILON(mach) is true because * some state interior to "mach" might point back to the beginning * for a closure */ eps = mkstate( SYM_EPSILON ); mach = link_machines( eps, mach ); mkxtion( mach, finalst[mach] ); return ( mach ); }/* mkor - make a machine that matches either one of two machines * * synopsis * * new = mkor( first, second ); * * new - a machine which matches either first's pattern or second's * first, second - machines whose patterns are to be or'ed (the | operator) * * note that first and second are both destroyed by the operation * the code is rather convoluted because an attempt is made to minimize * the number of epsilon states needed */int mkor( first, second )int first, second; { int eps, orend; if ( first == NIL ) return ( second ); else if ( second == NIL ) return ( first ); else { /* see comment in mkopt() about why we can't use the first state * of "first" or "second" if they satisfy "FREE_EPSILON" */ eps = mkstate( SYM_EPSILON ); first = link_machines( eps, first ); mkxtion( first, second ); if ( SUPER_FREE_EPSILON(finalst[first]) && accptnum[finalst[first]] == NIL ) { orend = finalst[first]; mkxtion( finalst[second], orend ); } else if ( SUPER_FREE_EPSILON(finalst[second]) && accptnum[finalst[second]] == NIL ) { orend = finalst[second]; mkxtion( finalst[first], orend ); } else { eps = mkstate( SYM_EPSILON ); first = link_machines( first, eps ); orend = finalst[first]; mkxtion( finalst[second], orend ); } } finalst[first] = orend; return ( first ); }/* mkposcl - convert a machine into a positive closure * * synopsis * new = mkposcl( state ); * * new - a machine matching the positive closure of "state" */int mkposcl( state )int state; { int eps; if ( SUPER_FREE_EPSILON(finalst[state]) ) { mkxtion( finalst[state], state ); return ( state ); } else { eps = mkstate( SYM_EPSILON ); mkxtion( eps, state ); return ( link_machines( state, eps ) ); } }/* mkrep - make a replicated machine * * synopsis * new = mkrep( mach, lb, ub ); * * new - a machine that matches whatever "mach" matched from "lb" * number of times to "ub" number of times * * note * if "ub" is INFINITY then "new" matches "lb" or more occurrences of "mach" */int mkrep( mach, lb, ub )int mach, lb, ub; { int base, tail, copy, i; base = copysingl( mach, lb - 1 ); if ( ub == INFINITY ) { copy = dupmachine( mach ); mach = link_machines( mach, link_machines( base, mkclos( copy ) ) ); } else { tail = mkstate( SYM_EPSILON ); for ( i = lb; i < ub; ++i ) { copy = dupmachine( mach ); tail = mkopt( link_machines( copy, tail ) ); } mach = link_machines( mach, link_machines( base, tail ) ); } return ( mach ); }/* mkstate - create a state with a transition on a given symbol * * synopsis * * state = mkstate( sym ); * * state - a new state matching sym * sym - the symbol the new state is to have an out-transition on * * note that this routine makes new states in ascending order through the * state array (and increments LASTNFA accordingly). The routine DUPMACHINE * relies on machines being made in ascending order and that they are * CONTIGUOUS. Change it and you will have to rewrite DUPMACHINE (kludge * that it admittedly is) */int mkstate( sym )int sym; { if ( ++lastnfa >= current_mns ) { if ( (current_mns += MNS_INCREMENT) >= MAXIMUM_MNS ) lerrif( "input rules are too complicated (>= %d NFA states)", current_mns ); ++num_reallocs; transchar = reallocate_integer_array( transchar, current_mns ); trans1 = reallocate_integer_array( trans1, current_mns ); trans2 = reallocate_integer_array( trans2, current_mns ); accptnum = reallocate_integer_array( accptnum, current_mns ); firstst = reallocate_integer_array( firstst, current_mns ); finalst = reallocate_integer_array( finalst, current_mns ); lastst = reallocate_integer_array( lastst, current_mns ); } transchar[lastnfa] = sym; trans1[lastnfa] = NO_TRANSITION; trans2[lastnfa] = NO_TRANSITION; accptnum[lastnfa] = NIL; firstst[lastnfa] = lastnfa; finalst[lastnfa] = lastnfa; lastst[lastnfa] = lastnfa; /* fix up equivalence classes base on this transition. Note that any * character which has its own transition gets its own equivalence class. * Thus only characters which are only in character classes have a chance * at being in the same equivalence class. E.g. "a|b" puts 'a' and 'b' * into two different equivalence classes. "[ab]" puts them in the same * equivalence class (barring other differences elsewhere in the input). */ if ( sym < 0 ) { /* we don't have to update the equivalence classes since that was * already done when the ccl was created for the first time */ } else if ( sym == SYM_EPSILON ) ++numeps; else { if ( useecs ) mkechar( sym, nextecm, ecgroup ); } return ( lastnfa ); }/* mkxtion - make a transition from one state to another * * synopsis * * mkxtion( statefrom, stateto ); * * statefrom - the state from which the transition is to be made * stateto - the state to which the transition is to be made */mkxtion( statefrom, stateto )int statefrom, stateto; { if ( trans1[statefrom] == NO_TRANSITION ) trans1[statefrom] = stateto; else if ( (transchar[statefrom] != SYM_EPSILON) || (trans2[statefrom] != NO_TRANSITION) ) flexfatal( "found too many transitions in mkxtion()" ); else { /* second out-transition for an epsilon state */ ++eps2; trans2[statefrom] = stateto; } } :MPW:MPW Tools:Tools with Source:flex ƒ:parse.y
/* parse.y - parser for flex input *//* * Copyright (c) 1987, the University of California * * The United States Government has rights in this work pursuant to * contract no. DE-AC03-76SF00098 between the United States Department of * Energy and the University of California. * * This program may be redistributed. Enhancements and derivative works * may be created provided the new works, if made available to the general * public, are made available for use by anyone. */%token CHAR NUMBER SECTEND SCDECL XSCDECL WHITESPACE NAME PREVCCL EOL%{#include "flexdef.h"int pat, scnum, eps, headcnt, trailcnt, anyccl, lastchar, i, actvp, rulelen;int trlcontxt, xcluflg, cclsorted, varlength;char clower();static int madeany = false; /* whether we've made the '.' character class */%}%%goal : initlex sect1 sect1end sect2 ;initlex : { /* initialize for processing rules */ /* create default DFA start condition */ scinstal( "INITIAL", false ); } ; sect1 : sect1 startconddecl WHITESPACE namelist1 EOL | | error EOL { synerr( "unknown error processing section 1" ); } ;sect1end : SECTEND ;startconddecl : SCDECL { /* these productions are separate from the s1object * rule because the semantics must be done before * we parse the remainder of an s1object */ xcluflg = false; } | XSCDECL { xcluflg = true; } ;namelist1 : namelist1 WHITESPACE NAME { scinstal( nmstr, xcluflg ); } | NAME { scinstal( nmstr, xcluflg ); } | error { synerr( "bad start condition list" ); } ;sect2 : sect2 initforrule flexrule EOL | ;initforrule : { /* initialize for a parse of one rule */ trlcontxt = varlength = false; trailcnt = headcnt = rulelen = 0; } ;flexrule : scon '^' re eol { pat = link_machines( $3, $4 ); add_accept( pat, headcnt, trailcnt ); for ( i = 1; i <= actvp; ++i ) scbol[actvsc[i]] = mkbranch( scbol[actvsc[i]], pat ); } | scon re eol { pat = link_machines( $2, $3 ); add_accept( pat, headcnt, trailcnt ); for ( i = 1; i <= actvp; ++i ) scset[actvsc[i]] = mkbranch( scset[actvsc[i]], pat ); } | '^' re eol { pat = link_machines( $2, $3 ); add_accept( pat, headcnt, trailcnt ); /* add to all non-exclusive start conditions, * including the default (0) start condition */ for ( i = 1; i <= lastsc; ++i ) if ( ! scxclu[i] ) scbol[i] = mkbranch( scbol[i], pat ); } | re eol { pat = link_machines( $1, $2 ); add_accept( pat, headcnt, trailcnt ); for ( i = 1; i <= lastsc; ++i ) if ( ! scxclu[i] ) scset[i] = mkbranch( scset[i], pat ); } | error { synerr( "unrecognized rule" ); } ;scon : '<' namelist2 '>' ;namelist2 : namelist2 ',' NAME { if ( (scnum = sclookup( nmstr )) == 0 ) synerr( "undeclared start condition" ); else actvsc[++actvp] = scnum; } | NAME { if ( (scnum = sclookup( nmstr )) == 0 ) synerr( "undeclared start condition" ); else actvsc[actvp = 1] = scnum; } | error { synerr( "bad start condition list" ); } ;eol : '$' { if ( trlcontxt ) { synerr( "trailing context used twice" ); $$ = mkstate( SYM_EPSILON ); } else { trlcontxt = true; if ( ! varlength ) headcnt = rulelen; ++rulelen; trailcnt = 1; eps = mkstate( SYM_EPSILON ); $$ = link_machines( eps, mkstate( EOLCHAR ) ); } } | { $$ = mkstate( SYM_EPSILON ); if ( trlcontxt ) { if ( varlength && headcnt == 0 ) /* both head and trail are variable-length */ synerr( "illegal trailing context" ); else trailcnt = rulelen; } } ;re : re '|' series { varlength = true; $$ = mkor( $1, $3 ); } | re2 series { $$ = link_machines( $1, $2 ); } | series { $$ = $1; } ;re2 : re '/' { /* this rule is separate from the others for "re" so * that the reduction will occur before the trailing * series is parsed */ if ( trlcontxt ) synerr( "trailing context used twice" ); else trlcontxt = true; if ( varlength ) /* the trailing context had better be fixed-length */ varlength = false; else headcnt = rulelen; rulelen = 0; $$ = $1; } ;series : series singleton { /* this is where concatenation of adjacent patterns * gets done */ $$ = link_machines( $1, $2 ); } | singleton { $$ = $1; } ;singleton : singleton '*' { varlength = true; $$ = mkclos( $1 ); } | singleton '+' { varlength = true; $$ = mkposcl( $1 ); } | singleton '?' { varlength = true; $$ = mkopt( $1 ); } | singleton '{' NUMBER ',' NUMBER '}' { varlength = true; if ( $3 > $5 || $3 <= 0 ) { synerr( "bad iteration values" ); $$ = $1; } else $$ = mkrep( $1, $3, $5 ); } | singleton '{' NUMBER ',' '}' { varlength = true; if ( $3 <= 0 ) { synerr( "iteration value must be positive" ); $$ = $1; } else $$ = mkrep( $1, $3, INFINITY ); } | singleton '{' NUMBER '}' { /* the singleton could be something like "(foo)", * in which case we have no idea what its length * is, so we punt here. */ varlength = true; if ( $3 <= 0 ) { synerr( "iteration value must be positive" ); $$ = $1; } else $$ = link_machines( $1, copysingl( $1, $3 - 1 ) ); } | '.' { if ( ! madeany ) { /* create the '.' character class */ anyccl = cclinit(); ccladd( anyccl, EOLCHAR ); cclnegate( anyccl ); if ( useecs ) mkeccl( ccltbl + cclmap[anyccl], ccllen[anyccl], nextecm, ecgroup, CSIZE ); madeany = true; } ++rulelen; $$ = mkstate( -anyccl ); } | fullccl { if ( ! cclsorted ) /* sort characters for fast searching. We use a * shell sort since this list could be large. */ cshell( ccltbl + cclmap[$1], ccllen[$1] ); if ( useecs ) mkeccl( ccltbl + cclmap[$1], ccllen[$1], nextecm, ecgroup, CSIZE ); ++rulelen; $$ = mkstate( -$1 ); } | PREVCCL { ++rulelen; $$ = mkstate( -$1 ); } | '"' string '"' { $$ = $2; } | '(' re ')' { $$ = $2; } | CHAR { ++rulelen; if ( $1 == '\0' ) synerr( "null in rule" ); if ( caseins && $1 >= 'A' && $1 <= 'Z' ) $1 = clower( $1 ); $$ = mkstate( $1 ); } ;fullccl : '[' ccl ']' { $$ = $2; } | '[' '^' ccl ']' { /* *Sigh* - to be compatible Unix lex, negated ccls * match newlines */#ifdef NOTDEF ccladd( $3, EOLCHAR ); /* negated ccls don't match '\n' */ cclsorted = false; /* because we added the newline */#endif cclnegate( $3 ); $$ = $3; } ;ccl : ccl CHAR '-' CHAR { if ( $2 > $4 ) synerr( "negative range in character class" ); else { if ( caseins ) { if ( $2 >= 'A' && $2 <= 'Z' ) $2 = clower( $2 ); if ( $4 >= 'A' && $4 <= 'Z' ) $4 = clower( $4 ); } for ( i = $2; i <= $4; ++i ) ccladd( $1, i ); /* keep track if this ccl is staying in alphabetical * order */ cclsorted = cclsorted && ($2 > lastchar); lastchar = $4; } $$ = $1; } | ccl CHAR { if ( caseins ) if ( $2 >= 'A' && $2 <= 'Z' ) $2 = clower( $2 ); ccladd( $1, $2 ); cclsorted = cclsorted && ($2 > lastchar); lastchar = $2; $$ = $1; } | { cclsorted = true; lastchar = 0; $$ = cclinit(); } ;string : string CHAR { if ( caseins ) if ( $2 >= 'A' && $2 <= 'Z' ) $2 = clower( $2 ); ++rulelen; $$ = link_machines( $1, mkstate( $2 ) ); } | { $$ = mkstate( SYM_EPSILON ); } ;%%/* synerr - report a syntax error * * synopsis * char str[]; * synerr( str ); */synerr( str )char str[]; { syntaxerror = true;#ifdef MACINTOSH fprintf( stderr, "File %s ;Line %d # Syntax error: %s\n",infilename,linenum, str );#else fprintf( stderr, "Syntax error at line %d: %s\n", linenum, str );#endif }/* yyerror - eat up an error message from the parser * * synopsis * char msg[]; * yyerror( msg ); */yyerror( msg )char msg[]; { } :MPW:MPW Tools:Tools with Source:flex ƒ:README
This is the initial release of flex, a replacement for the lex(1)tool. As the copyright indicates, this distribution can be freelyredistributed.Some notes on the distribution: Yes, there are some nigglingtures which are not available which seem like they'd be easy to add. They're not, or if they are then the straight-forward implementation of them would slow down the scanner. Unfortunately I am unable to do any further work on flex other than bug fixes, so if there's something you've just gotta have, you'd better be willing to dive into the code. I'll be happy to give (fairly high-level) advice on how to proceed. The compressed tables have been tested pretty thoroughly in the past, though may be suffering from bit-rot. The fast/full tables have been recently implemented and are more likely to have bugs. For a System V machine, add the #define "SV". Not guaranteed to do the full job, but a step in the right direction. Flex has been successfully ported to Sun Unix and 4.3BSD Vax Unix.The flex distribution consists of the following files: README This message Changes Differences between this release and the beta-test Makefile flexdef.h parse.y scan.l ccl.c dfa.c flex sources ecs.c main.c misc.c nfa.c sym.c tblcmp.c yylex.c scan.c.dist pre-flex'd version of scan.l flex.skel flex.fastskel flexskelcom.h skeleton scanner sources flexskeldef.h fastskeldef.h flex.1 manual entry Timings a brief note comparing timings of flex vs. lex[ The following section is only true if you got the files from FTP to LBL, directly, and not from the more widely-distributed comp.sources.unix publication. --Rich $alzThe files are packaged as a compressed shell archive, which in turncontains seven shell archives. Create a directory where you want flexto live, cd there, and use uncompress flex.shar.Z sh flex.shar sh flex.shar.1 sh flex.shar.2 sh flex.shar.3 sh flex.shar.4 sh flex.shar.5 sh flex.shar.6 sh flex.shar.7to extract them.]Either move {flexskelcom.h,flexskeldef.h,fastskeldef.h} into /usr/includeor edit {flex.skel,flex.fastskel,flexskeldef.h,fastskeldef.h,scan.c.dist}and wire in the full pathname of where you are going to keep the include files.Decide where you want to keep {flex.skel,flex.fastskel} (suggestion:/usr/local/lib) and move it there. Edit "Makefile" and change thedefinitions of SKELETON_FILE and F_SKELETON_FILE to reflect the fullpathnames of {flex.skel,flex.fastskel}.To make flex for the first time, use: make first_flexwhich uses a pre-generated copy of the scanner whose source is in flex.Assuming it builds successfully, you can test it using make testThe "diff" should not show any differences.If you're feeling adventurous, rebuild scan.c using variouscombinations of FLEX_FLAGS, each time trying "make test" whenyou're done. To rebuild it, do rm scan.c make FLEX_FLAGS="..."where "..." is one of: -ist -c -ist -ce -ist -cm -ist -cfe -ist -cFeand testing using: make FLEX_FLAGS="..." testFormat the manual entry using nroff -man flex.1Please send problems and feedback to: vern@lbl-{csam,rtsg}.arpa or ucbvax!lbl-csam.arpa!vern Vern Paxson Real Time Systems Group Bldg. 46A Lawrence Berkeley Laboratory 1 Cyclotron Rd. Berkeley, CA 94720 (415) 486-6411 :MPW:MPW Tools:Tools with Source:flex ƒ:README_for_Macintosh
Flex for the Mac (MPW). Port by Earle Horton, May 1988Updated November, 1988. Ported to Aztec C 3.6c. Fixes to allow shortints and to allow for user definition of end-of-line character./* * Copyright (c) 1987, the University of California * * The United States Government has rights in this work pursuant to * contract no. DE-AC03-76SF00098 between the United States Department of * Energy and the University of California. * * This program may be redistributed. Enhancements and derivative works * may be created provided the new works, if made available to the general * public, are made available for use by anyone. */This document consists of general comments regarding the implementationof Flex as a Macintosh Programmer's Workshop tool. Comments regardingthe building of flex and its use are freely interspersed.The preprocessor macro "MACINTOSH" must be defined, both in Flex codeand in scanners produced by Flex.MPW 2.0.2 tools are limited to 32k of global data. This necessitates use ofmalloc() to obtain space for a number of Flex's work buffers. This isdone both in the source code for Flex and in the scanners produced byFlex, and is determined by definition of the pre-processor macroMALLOC_BUFFERS. Scanners produced by Flex can save 5k of global dataspace if compiled with MALLOC_BUFFERS #defined. Still, the fast scanneroptions will probably not work in this environment because of the largetables used.I have supplied a function gettime() which returns a string producedby IUTimeString(). Results may not be the same as those produced byversions of Flex running on UNIX systems. If you are interested inporting Flex to another Macintosh development system, then you shouldlook in misc.c and verify that the calling sequence is correct for your compiler. This is the only Macintosh-specific system call used.Input to Macintosh Flex scanners is raw. Characters which terminatelines are expected to be equal to EOLCHAR, which is defined in"flexskelcom.h" to be equal to 13 for the Macintosh and 10 for othersystems. Note that MACINTOSH must be defined when you compile your Flexoutput, or the default value of 10 for newline will used.The files "flex.skel" and "flex.fastskel" are found by use of environmentvariables thusly: set SKELETON_FILE "{clibraries}flex.skel" export SKELETON_FILE set F_SKELETON_FILE "{clibraries}flex.fastskel" export F_SKELETON_FILE{Clibraries} is where I keep my copies. Copies of the three #includefiles flexskelcom.h,flexskeldef.h and fastskeldef.h should also beput where the C compiler can find them, usually {CIncludes}.The temporary file used by Flex has a constant name. If you are battyenough to have files named "/tmp/flexXXXXXX" lying around you will lose them. If you run Flex under the Aztec shell, you need a "/tmp"directory for flex to put this file in. A folder named "tmp" at theroot level on the same volume as the shell will do.The MPW Makefile uses stubs.c.o. Stubs.c is included in the MPW Cdistribution in the "CExamples" folder, and provides dummy functionsfor those routines which are not needed by tools. This causes thelinker to emit duplicate entry warnings, unless "-d" is turned on,which it is in the supplied Makefile.This distribution contains files which are not used in the MPWimplementation, but which will be needed in case anyone wants to compile Flex on a non-Mac system. For this reason, I request thatif you redistribute the Flex sources, you distribute ALL the fileswhich I supply. In particular, "scan.c.dist" will be essential toanyone attempting to compile these sources on a non-Mac, and possiblyon a Mac using another Mac development system.This code incorporates fixes to a bug in the original code which didnot allow scanning of Macintosh option-characters (those with thehigh bit set). This fix should also allow it work with character sets such as DEC multi-nationals. I have verified that this fixallows Flex to scan non-ASCII characters properly on a 4.3 BSDsystem, but have not tried it with any other systems at this time.Happy scanning!Earle :MPW:MPW Tools:Tools with Source:flex ƒ:scan.c
6, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226 } ;static short int c[831] = { 0, 0, 1, 1, 10, 11, 11, 256, 10, 12, 12, 29, 21, 30, 19, 19, 20, 20, 249, 21, 245, 21, 1, 1, 1, 1, 1, 1, 2, 2, 19, 2, 20, 2, 22, 31, 71, 23, 29, 2, 30, 22, 31, 22, 23, 23, 45, 45, 2, 2, 2, 2, 2, 2, 3, 3, 3, 32, 3, 24, 220, 3, 3, 71, 32, 3, 24, 24, 3, 33, 3, 3, 34, 55, 55, 216, 33, 213, 35, 34, 3, 3, 4, 4, 4, 35, 4, 4, 36, 4, 4, 37, 37, 4, 211, 36, 4, 59, 4, 4, 208, 4, 38, 38, 59, 83, 83, 37, 4, 4, 13, 48, 39, 39, 40, 40, 13, 39, 38, 40, 196, 13, 13, 13, 13, 13, 13, 14, 88, 48, 91, 48, 48, 14, 100, 88, 192, 91, 14, 14, 14, 14, 14, 14, 17, 100, 52, 52, 124, 189, 95, 52, 17, 108, 111, 17, 17, 95, 122, 122, 108, 111, 188, 122, 128, 128, 144, 144, 152, 139, 139, 17, 18, 52, 139, 124, 147, 147, 152, 145, 18, 155, 156, 18, 18, 145, 145, 157, 185, 156, 178, 155, 165, 165, 167, 167, 139, 157, 173, 18, 25, 25, 195, 195, 203, 25, 155, 195, 195, 173, 25, 197, 197, 202, 203, 206, 204, 210, 210, 177, 202, 161, 206, 218, 218, 25, 204, 25, 26, 26, 217, 217, 142, 26, 141, 217, 217, 136, 26, 219, 219, 221, 221, 225, 225, 134, 221, 221, 132, 130, 127, 125, 121, 26, 116, 26, 60, 60, 113, 110, 104, 101, 92, 77, 60, 60, 60, 60, 60, 60, 61, 61, 73, 69, 66, 61, 64, 63, 58, 49, 47, 61, 42, 28, 27, 16, 15, 9, 6, 5, 0, 0, 0, 0, 0, 0, 0, 61, 151, 151, 0, 0, 0, 0, 0, 0, 151, 151, 151, 151, 151, 151, 0, 0, 151, 153, 153, 0, 0, 0, 153, 0, 0, 0, 0, 0, 153, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 153, 227, 227, 227, 227, 227, 227, 227, 227, 227, 227, 228, 228, 228, 228, 228, 228, 228, 228, 228, 228, 229, 229, 229, 229, 229, 229, 229, 229, 229, 229, 230, 230, 230, 230, 230, 230, 230, 230, 230, 230, 231, 23 231, 231, 231, 231, 231, 231, 231, 232, 232, 232, 232, 232, 232, 232, 232, 232, 232, 233, 233, 0, 233, 233, 233, 233, 233, 233, 233, 234, 234, 234, 234, 234, 234, 234, 234, 234, 234, 235, 235, 235, 235, 235, 235, 235, 235, 235, 235, 236, 236, 0, 236, 236, 236, 236, 236, 236, 236, 237, 237, 0, 237, 237, 237, 237, 237, 237, 237, 238, 238, 238, 238, 238, 238, 238, 238, 238, 238, 239, 239, 239, 239, 239, 239, 239, 239, 239, 239, 240, 240, 240, 240, 240, 240, 240, 240, 240, 240, 241, 241, 241, 241, 241, 241, 241, 241, 241, 241, 242, 242, 242, 242, 242, 242, 242, 242, 242, 242, 243, 243, 243, 243, 243, 243, 243, 243, 243, 243, 244, 244, 244, 244, 244, 244, 244, 244, 244, 244, 246, 246, 246, 246, 246, 246, 246, 246, 246, 246, 247, 247, 247, 247, 247, 247, 247, 247, 247, 247, 248, 248, 248, 248, 248, 248, 248, 248, 248, 248, 250, 250, 0, 250, 250, 250, 250, 250, 0, 250, 251, 251, 0, 251, 251, 251, 251, 251, 251, 251, 252, 252, 0, 252, 252, 252, 252, 252, 252, 252, 253, 253, 253, 253, 253, 253, 253, 253, 253, 253, 254, 0, 0, 254, 254, 254, 254, 254, 254, 254, 255, 255, 0, 255, 255, 255, 255, 255, 255, 255, 257, 257, 0, 257, 257, 257, 257, 257, 257, 257, 258, 258, 0, 258, 258, 258, 258, 258, 258, 258, 259, 259, 0, 259, 259, 259, 259, 259, 0, 259, 260, 260, 0, 0, 0, 260, 260, 260, 260, 261, 261, 0, 261, 261, 261, 261, 261, 261, 261, 262, 262, 0, 262, 262, 0, 262, 262, 262, 262, 263, 263, 0, 0, 263, 263, 263, 0, 263, 263, 264, 264, 0, 264, 264, 264, 264, 264, 264, 264, 265, 265, 265, 265, 265, 265, 265, 265, 265, 265, 266, 266, 0, 266, 266, 266, 266, 266, 266, 266, 267, 267, 267, 267, 267, 267, 267, 267, 267, 267, 268, 268, 268, 268, 268, 268, 268, 268, 268, 268, 269, 269, 0, 269, 269, 269, 269, 269, 269, 270, 270, 270, 270, 270, 270, 270, 270, 270, 270, 271, 271, 0, 271, 271, 271, 271, 271, 271, 271, 272, 272, 272, 272, 272, 272, 272, 272, 272, 272, 273, 273, 273, 273, 273, 273, 273, 273, 273, 273, 274, 274, 274, 274, 274, 274, 274, 274, 274, 274, 275, 275, 0, 275, 275, 275, 275, 275, 275, 275, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226 } ;/* these declarations have to come after the section 1 code or lint gets * confused about whether the variables are used */FILE *yyin = stdin, *yyout = stdout;/* these variables are all declared out here so that section 3 code can * manipulate them */static int yy_start, yy_b_buf_p, yy_c_buf_p, yy_e_buf_p;static int yy_saw_eof, yy_init = 1;/* yy_ch_buf has to be 1 character longer than YY_BUF_SIZE, since when * setting up yytext we can try to put a '\0' just past the end of the * matched text */#ifdef MALLOC_BUFFERSstatic char *yy_ch_buf = 0L;static int *yy_st_buf = 0L;#elsestatic char yy_ch_buf[YY_BUF_SIZE + 1];static int yy_st_buf[YY_BUF_SIZE];#endifstatic char yy_hold_char;char *yytext;static int yyleng;YY_DECL { int yy_n_chars, yy_lp, yy_iii, yy_buf_pos, yy_act; static int bracelevel, didadef; int i, cclval; char nmdef[MAXLINE], myesc();#ifdef MALLOC_BUFFERS if(yy_ch_buf == 0L){ yy_ch_buf = (char *)malloc(YY_BUF_SIZE + 1); yy_st_buf = (int *)malloc(YY_BUF_SIZE * sizeof(int)); if(yy_ch_buf == 0L || yy_st_buf == 0L){ fprintf( stderr, "Out of memory\n"); exit(-1); } }#endif if ( yy_init ) { YY_INIT; yy_start = 1; yy_init = 0; } goto get_next_token;do_action: for ( ; ; ) { YY_DO_BEFORE_ACTION#ifdef FLEX_DEBUG fprintf( stderr, "--accepting rule #%d\n", yy_act );#endif switch ( yy_act ) {case 1:# line 58 "scan.l"++linenum; ECHO; /* indented code */ YY_BREAKcase 2:# line 59 "scan.l"++linenum; ECHO; /* treat as a comment */ YY_BREAKcase 3:# line 60 "scan.l"ECHO; BEGIN(C_COMMENT); YY_BREAKcase 4:# line 61 "scan.l"return ( SCDECL ); YY_BREAKcase 5:# line 62 "scan.l"return ( XSCDECL ); YY_BREAKcase 6:# line 63 "scan.l"++linenum; line_directive_out( stdout ); BEGIN(CODEBLOCK); YY_BREAKcase 7:# line 64 "scan.l"return ( WHITESPACE ); YY_BREAKcase 8:# line 66 "scan.l"{ sectnum = 2; line_directive_out( stdout ); BEGIN(SECT2PROLOG); return ( SECTEND ); } YY_BREAKcase 9:# line 73 "scan.l"{ fprintf( stderr, "old-style lex command at line %d ignored:\n\t%s", linenum, yytext ); ++linenum; } YY_BREAKcase 10:# line 80 "scan.l"{ (void) strcpy( nmstr, yytext ); didadef = false; BEGIN(PICKUPDEF); } YY_BREAKcase 11:# line 86 "scan.l"RETURNNAME; YY_BREAKcase 12:# line 87 "scan.l"++linenum; /* allows blank lines in section 1 */ YY_BREAKcase 13:# line 88 "scan.l"++linenum; return ( EOL ); YY_BREAKcase 14:# line 89 "scan.l"synerr( "illegal character" ); BEGIN(RECOVER); YY_BREAKcase 15:# line 92 "scan.l"ECHO; BEGIN(0); YY_BREAKcase 16:# line 93 "scan.l"++linenum; ECHO; BEGIN(0); YY_BREAKcase 17:# line 94 "scan.l"ECHO; YY_BREAKcase 18:# line 95 "scan.l"ECHO; YY_BREAKcase 19:# line 96 "scan.l"++linenum; ECHO; YY_BREAKcase 20:# line 98 "scan.l"++linenum; BEGIN(0); YY_BREAKcase 21:# line 99 "scan.l"++linenum; ECHO; YY_BREAKcase 22:# line 101 "scan.l"/* separates name and definition */ YY_BREAKcase 23:# line 103 "scan.l"{ (void) strcpy( nmdef, yytext ); for ( i = strlen( nmdef ) - 1; i >= 0 && nmdef[i] == ' ' || nmdef[i] == '\t'; --i ) ; nmdef[i + 1] = '\0'; ndinstal( nmstr, nmdef ); didadef = true; } YY_BREAKcase 24:# line 118 "scan.l"{ if ( ! didadef ) synerr( "incomplete name definition" ); BEGIN(0); ++linenum; } YY_BREAKcase 25:# line 125 "scan.l"++linenum; BEGIN(0); RETURNNAME; YY_BREAKcase 26:YY_DO_BEFORE_SCAN; /* undo effects of setting up yytext */yy_c_buf_p -= 1;YY_DO_BEFORE_ACTION; /* set up yytext again */# line 128 "scan.l"{ ++linenum; ACTION_ECHO; MARK_END_OF_PROLOG; BEGIN(SECT2); } YY_BREAKcase 27:# line 135 "scan.l"++linenum; ACTION_ECHO; YY_BREAKcase 28:# line 137 "scan.l"++linenum; /* allow blank lines in section 2 */ YY_BREAK /* this horrible mess of a rule matches indented lines which * do not contain "/*". We need to make the distinction because * otherwise this rule will be taken instead of the rule which * matches the beginning of comments like this one */case 29:# line 144 "scan.l"{ synerr( "indented code found outside of action" ); ++linenum; } YY_BREAKcase 30:# line 149 "scan.l"BEGIN(SC); return ( '<' ); YY_BREAKcase 31:# line 150 "scan.l"return ( '^' ); YY_BREAKcase 32:# line 151 "scan.l"BEGIN(QUOTE); return ( '"' ); YY_BREAKcase 33:YY_DO_BEFORE_SCAN; /* undo effects of setting up yytext */yy_c_buf_p = yy_b_buf_p;YY_DO_BEFORE_ACTION; /* set up yytext again */# line 152 "scan.l"BEGIN(NUM); return ( '{' ); YY_BREAKcase 34:# line 153 "scan.l"BEGIN(BRACEERROR); YY_BREAKcase 35:YY_DO_BEFORE_SCAN; /* undo effects of setting up yytext */yy_c_buf_p = yy_b_buf_p;YY_DO_BEFORE_ACTION; /* set up yytext again */# line 154 "scan.l"return ( '$' ); YY_BREAKcase 36:# line 156 "scan.l"{ bracelevel = 1; BEGIN(PERCENT_BRACE_ACTION); return ( EOL ); } YY_BREAKcase 37:# line 161 "scan.l"++linenum; return ( EOL ); YY_BREAKcase 38:# line 163 "scan.l"ACTION_ECHO; BEGIN(C_COMMENT_2); YY_BREAKcase 39:# line 165 "scan.l"{ /* needs to be separate from following rule due to * bug with trailing context */ bracelevel = 0; BEGIN(ACTION); return ( EOL ); } YY_BREAKcase 40:YY_DO_BEFORE_SCAN; /* undo effects of setting up yytext */yy_c_buf_p -= 1;YY_DO_BEFORE_ACTION; /* set up yytext again */# line 173 "scan.l"{ bracelevel = 0; BEGIN(ACTION); return ( EOL ); } YY_BREAKcase 41:# line 179 "scan.l"++linenum; return ( EOL ); YY_BREAKcase 42:# line 181 "scan.l"{ /* guarantee that the SECT3 rule will have something * to match */ yyless(1); sectnum = 3; BEGIN(SECT3); return ( EOF ); /* to stop the parser */ } YY_BREAKcase 43:# line 191 "scan.l"{ (void) strcpy( nmstr, yytext ); /* check to see if we've already encountered this ccl */ if ( (cclval = ccllookup( nmstr )) ) { yylval = cclval; ++cclreuse; return ( PREVCCL ); } else { /* we fudge a bit. We know that this ccl will * soon be numbered as lastccl + 1 by cclinit */ cclinstal( nmstr, lastccl + 1 ); /* push back everything but the leading bracket * so the ccl can be rescanned */ PUT_BACK_STRING(nmstr, 1); BEGIN(FIRSTCCL); return ( '[' ); } } YY_BREAKcase 44:# line 218 "scan.l"{ register char *nmdefptr; char *ndlookup(); (void) strcpy( nmstr, yytext ); nmstr[yyleng - 1] = '\0'; /* chop trailing brace */ /* lookup from "nmstr + 1" to chop leading brace */ if ( ! (nmdefptr = ndlookup( nmstr + 1 )) ) synerr( "undefined {name}" ); else { /* push back name surrounded by ()'s */ unput(')'); PUT_BACK_STRING(nmdefptr, 0); unput('('); } } YY_BREAKcase 45:# line 237 "scan.l"return ( yytext[0] ); YY_BREAKcase 46:# line 238 "scan.l"RETURNCHAR; YY_BREAKcase 47:# line 239 "scan.l"++linenum; return ( EOL ); YY_BREAKcase 48:# line 242 "scan.l"return ( ',' ); YY_BREAKcase 49:# line 243 "scan.l"BEGIN(SECT2); return ( '>' ); YY_BREAKcase 50:YY_DO_BEFORE_SCAN; /* undo effects of setting up yytext */yy_c_buf_p = yy_b_buf_p;YY_DO_BEFORE_ACTION; /* set up yytext again */# line 244 "scan.l"BEGIN(CARETISBOL); return ( '>' ); YY_BREAKcase 51:# line 245 "scan.l"RETURNNAME; YY_BREAKcase 52:# line 246 "scan.l"synerr( "bad start condition name" ); YY_BREAKcase 53:# line 248 "scan.l"BEGIN(SECT2); return ( '^' ); YY_BREAKcase 54:# line 251 "scan.l"RETURNCHAR; YY_BREAKcase 55:# line 252 "scan.l"BEGIN(SECT2); return ( '"' ); YY_BREAKcase 56:# line 254 "scan.l"{ synerr( "missing quote" ); BEGIN(SECT2); ++linenum; return ( '"' ); } YY_BREAKcase 57:YY_DO_BEFORE_SCAN; /* undo effects of setting up yytext */yy_c_buf_p = yy_b_buf_p;YY_DO_BEFORE_ACTION; /* set up yytext again */# line 262 "scan.l"BEGIN(CCL); return ( '^' ); YY_BREAKcase 58:YY_DO_BEFORE_SCAN; /* undo effects of setting up yytext */yy_c_buf_p = yy_b_buf_p;YY_DO_BEFORE_ACTION; /* set up yytext again */# line 263 "scan.l"return ( '^' ); YY_BREAKcase 59:# line 264 "scan.l"BEGIN(CCL); yylval = '-'; return ( CHAR ); YY_BREAKcase 60:# line 265 "scan.l"BEGIN(CCL); RETURNCHAR; YY_BREAKcase 61:YY_DO_BEFORE_SCAN; /* undo effects of setting up yytext */yy_c_buf_p = yy_b_buf_p;YY_DO_BEFORE_ACTION; /* set up yytext again */# line 267 "scan.l"return ( '-' ); YY_BREAKcase 62:# line 268 "scan.l"RETURNCHAR; YY_BREAKcase 63:# line 269 "scan.l"BEGIN(SECT2); return ( ']' ); YY_BREAKcase 64:# line 272 "scan.l"{ yylval = myctoi( yytext ); return ( NUMBER ); } YY_BREAKcase 65:# line 277 "scan.l"return ( ',' ); YY_BREAKcase 66:# line 278 "scan.l"BEGIN(SECT2); return ( '}' ); YY_BREAKcase 67:# line 280 "scan.l"{ synerr( "bad character inside {}'s" ); BEGIN(SECT2); return ( '}' ); } YY_BREAKcase 68:# line 286 "scan.l"{ synerr( "missing }" ); BEGIN(SECT2); ++linenum; return ( '}' ); } YY_BREAKcase 69:# line 294 "scan.l"synerr( "bad name in {}'s" ); BEGIN(SECT2); YY_BREAKcase 70:# line 295 "scan.l"synerr( "missing }" ); ++linenum; BEGIN(SECT2); YY_BREAKcase 71:# line 298 "scan.l"bracelevel = 0; YY_BREAKcase 72:# line 299 "scan.l"ACTION_ECHO; YY_BREAKcase 73:# line 300 "scan.l"{ ++linenum; ACTION_ECHO; if ( bracelevel == 0 ) { fputs( "\tYY_BREAK\n", temp_action_file ); BEGIN(SECT2); } } YY_BREAKcase 74:# line 310 "scan.l"ACTION_ECHO; ++bracelevel; YY_BREAKcase 75:# line 311 "scan.l"ACTION_ECHO; --bracelevel; YY_BREAKcase 76:# line 312 "scan.l"ACTION_ECHO; YY_BREAKcase 77:# line 313 "scan.l"ACTION_ECHO; BEGIN(ACTION_COMMENT); YY_BREAKcase 78:# line 314 "scan.l"ACTION_ECHO; /* character constant */ YY_BREAKcase 79:# line 315 "scan.l"ACTION_ECHO; BEGIN(ACTION_STRING); YY_BREAKcase 80:# line 316 "scan.l"{ ++linenum; ACTION_ECH ( bracelevel == 0 ) { fputs( "\tYY_BREAK\n", temp_action_file ); BEGIN(SECT2); } } YY_BREAKcase 81:# line 325 "scan.l"ACTION_ECHO; YY_
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:flex ƒ:scan.c
+++++ Continued from previous card +++++
BREAKcase 82:# line 327 "scan.l"ACTION_ECHO; BEGIN(ACTION); YY_BREAKcase 83:# line 328 "scan.l"ACTION_ECHO; YY_BREAKcase 84:# line 329 "scan.l"ACTION_ECHO; YY_BREAKcase 85:# line 330 "scan.l"++linenum; ACTION_ECHO; YY_BREAKcase 86:# line 331 "scan.l"ACTION_ECHO; YY_BREAKcase 87:# line 333 "scan.l"ACTION_ECHO; BEGIN(SECT2); YY_BREAKcase 88:# line 334 "scan.l"++linenum; ACTION_ECHO; BEGIN(SECT2); YY_BREAKcase 89:# line 335 "scan.l"ACTION_ECHO; YY_BREAKcase 90:# line 336 "scan.l"ACTION_ECHO; YY_BREAKcase 91:# line 337 "scan.l"++linenum; ACTION_ECHO; YY_BREAKcase 92:# line 339 "scan.l"ACTION_ECHO; YY_BREAKcase 93:# line 340 "scan.l"ACTION_ECHO; YY_BREAKcase 94:# line 341 "scan.l"++linenum; ACTION_ECHO; YY_BREAKcase 95:# line 342 "scan.l"ACTION_ECHO; BEGIN(ACTION); YY_BREAKcase 96:# line 343 "scan.l"ACTION_ECHO; YY_BREAKcase 97:# line 346 "scan.l"{ yylval = myesc( yytext ) & BYTEMASK; return ( CHAR ); } YY_BREAKcase 98:# line 351 "scan.l"{ yylval = myesc( yytext ) & BYTEMASK; BEGIN(CCL); return ( CHAR ); } YY_BREAKcase 99:# line 358 "scan.l"{ register int numchars; /* black magic - we know the names of a flex scanner's * internal variables. We cap the input buffer with * an end-of-string and dump it to the output. */ YY_DO_BEFORE_SCAN; /* recover from setting up yytext */#ifdef FLEX_FAST_SKEL fputs( yy_c_buf_p + 1, stdout );#else yy_ch_buf[yy_e_buf_p + 1] = '\0'; /* ignore the first character; it's the second '%' * put back by the yyless(1) above */ fputs( yy_ch_buf + yy_c_buf_p + 1, stdout );#endif /* if we don't do this, the data written by write() * can get overwritten when stdout is finally flushed */ (void) fflush( stdout ); while ( (numchars = read( fileno(yyin), yy_ch_buf, YY_BUF_MAX )) > 0 ) (void) write( fileno(stdout), yy_ch_buf, numchars ); if ( numchars < 0 ) flexerror( "fatal read errotion 3" ); return ( EOF ); } YY_BREAKcase YY_NEW_FILE:break; /* begin reading from new file */case YY_DO_DEFAULT:YY_DEFAULT_ACTION;break;case YY_END_TOK:return ( YY_END_TOK );default:YY_FATAL_ERROR( "fatal flex scanner internal error" ); }get_next_token: { register int yy_curst; register char yy_sym; YY_DO_BEFORE_SCAN /* set up to begin running DFA */ yy_curst = yy_start; if ( yy_ch_buf[yy_c_buf_p] == EOLCHAR ) ++yy_curst; /* yy_b_buf_p points to the position in yy_ch_buf * of the start of the current run. */ yy_b_buf_p = yy_c_buf_p + 1; do /* until the machine jams */ { if ( yy_c_buf_p == yy_e_buf_p ) { /* need more input */ if ( yy_e_buf_p >= YY_BUF_LIM ) { /* not enough room to do another read */ /* see if we can make some room for more chars */ yy_n_chars = yy_e_buf_p - yy_b_buf_p; if ( yy_n_chars >= 0 ) /* shift down buffer to make room */ for ( yy_iii = 0; yy_iii <= yy_n_chars; ++yy_iii ) { yy_buf_pos = yy_b_buf_p + yy_iii; yy_ch_buf[yy_iii] = yy_ch_buf[yy_buf_pos]; yy_st_buf[yy_iii] = yy_st_buf[yy_buf_pos]; } yy_b_buf_p = 0; yy_e_buf_p = yy_n_chars; if ( yy_e_buf_p >= YY_BUF_LIM ) YY_FATAL_ERROR( "flex input buffer overflowed" ); yy_c_buf_p = yy_e_buf_p; } else if ( yy_saw_eof ) {saweof: if ( yy_b_buf_p > yy_e_buf_p ) { if ( yywrap() ) { yy_act = YY_END_TOK; goto do_action; } else { YY_INIT; yy_act = YY_NEW_FILE; goto do_action; } } else /* do a jam to eat up more input */ {#ifndef FLEX_INTERACTIVE_SCANNER /* we're going to decrement yy_c_buf_p upon doing * the jam. In this case, that's wrong, since * it points to the last non-jam character. So * we increment it now to counter the decrement. */ ++yy_c_buf_p;#endif break; } } YY_INPUT( (yy_ch_buf + yy_c_buf_p + 1), yy_n_chars, YY_MAX_LINE ); if ( yy_n_chars == YY_NULL ) { if ( yy_saw_eof ) YY_FATAL_ERROR( "flex scanner saw EOF twice - shouldn't happen" ); yy_saw_eof = 1; goto saweof; } yy_e_buf_p += yy_n_chars; } ++yy_c_buf_p;#ifdef FLEX_USE_ECS yy_sym = e[(yy_ch_buf[yy_c_buf_p] & BYTEMASK)];#else yy_sym = yy_ch_buf[yy_c_buf_p];#endif#ifdef FLEX_FULL_TABLE yy_curst = n[yy_curst][yy_sym];#else /* get next state from compressed table */ while ( c[b[yy_curst] + yy_sym] != yy_curst ) { yy_curst = d[yy_curst];#ifdef FLEX_USE_MECS /* we've arrange it so that templates are never chained * to one another. This means we can afford make a * very simple test to see if we need to convert to * yy_sym's meta-equivalence class without worrying * about erroneously looking up the meta-equivalence * class twice */ if ( yy_curst >= YY_TEMPLATE ) yy_sym = m[yy_sym];#endif } yy_curst = n[b[yy_curst] + yy_sym];#endif yy_st_buf[yy_c_buf_p] = yy_curst; }#ifdef FLEX_INTERACTIVE_SCANNER while ( b[yy_curst] != YY_JAM_BASE );#else while ( yy_curst != YY_JAM ); --yy_c_buf_p; /* put back character we jammed on */#endif if ( yy_c_buf_p >= yy_b_buf_p ) { /* we matched some text */ yy_curst = yy_st_buf[yy_c_buf_p]; yy_lp = l[yy_curst];#ifdef FLEX_REJECT_ENABLEDfind_rule: /* we branch to this label when doing a REJECT */#endif for ( ; ; ) /* until we find what rule we matched */ {#ifdef FLEX_REJECT_ENABLED if ( yy_lp && yy_lp < l[yy_curst + 1] ) { yy_act = a[yy_lp]; goto do_action; /* "continue 2" */ }#else if ( yy_lp ) { yy_act = yy_lp; goto do_action; /* "continue 2" */ }#endif if ( --yy_c_buf_p < yy_b_buf_p ) break; yy_curst = yy_st_buf[yy_c_buf_p]; yy_lp = l[yy_curst]; } } /* if we got this far, then we didn't find any accepting * states */ /* so that the default applies to the first char read */ ++yy_c_buf_p; yy_act = YY_DO_DEFAULT; } } /*NOTREACHED*/ }static int unput( c )char c; { YY_DO_BEFORE_SCAN; /* undo effects of setting up yytext */ if ( yy_c_buf_p == 0 ) { register int i; register int yy_buf_pos = YY_BUF_MAX; for ( i = yy_e_buf_p; i >= yy_c_buf_p; --i ) { yy_ch_buf[yy_buf_pos] = yy_ch_buf[i]; yy_st_buf[yy_buf_pos] = yy_st_buf[i]; --yy_buf_pos; } yy_c_buf_p = YY_BUF_MAX - yy_e_buf_p; yy_e_buf_p = YY_BUF_MAX; } if ( yy_c_buf_p <= 0 ) YY_FATAL_ERROR( "flex scanner push-back overflow" ); if ( yy_c_buf_p >= yy_b_buf_p && yy_ch_buf[yy_c_buf_p] == EOLCHAR ) yy_ch_buf[yy_c_buf_p - 1] = EOLCHAR; yy_ch_buf[yy_c_buf_p--] = c; YY_DO_BEFORE_ACTION; /* set up yytext again */ }static int input() { int c; YY_DO_BEFORE_SCAN if ( yy_c_buf_p == yy_e_buf_p ) { /* need more input */ int yy_n_chars; /* we can throw away the entire current buffer */ if ( yy_saw_eof ) { if ( yywrap() ) return ( EOF ); YY_INIT; } yy_b_buf_p = 0; YY_INPUT( yy_ch_buf, yy_n_chars, YY_MAX_LINE ); if ( yy_n_chars == YY_NULL ) { yy_saw_eof = 1; if ( yywrap() ) return ( EOF ); YY_INIT; return ( input() ); } yy_c_buf_p = -1; yy_e_buf_p = yy_n_chars - 1; } c = yy_ch_buf[++yy_c_buf_p]; YY_DO_BEFORE_ACTION; return ( c & BYTEMASK); }# line 392 "scan.l" :MPW:MPW Tools:Tools with Source:flex ƒ:scan.c.dist
:MPW:MPW Tools:Tools with Source:flex ƒ:scan.c.dist
+++++ Continued from previous card +++++
, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226 } ;static short int c[831] = { 0, 0, 1, 1, 10, 11, 11, 256, 10, 12, 12, 29, 21, 30, 19, 19, 20, 20, 249, 21, 245, 21, 1, 1, 1, 1, 1, 1, 2, 2, 19, 2, 20, 2, 22, 31, 71, 23, 29, 2, 30, 22, 31, 22, 23, 23, 45, 45, 2, 2, 2, 2, 2, 2, 3, 3, 3, 32, 3, 24, 220, 3, 3, 71, 32, 3, 24, 24, 3, 33, 3, 3, 34, 55, 55, 216, 33, 213, 35, 34, 3, 3, 4, 4, 4, 35, 4, 4, 36, 4, 4, 37, 37, 4, 211, 36, 4, 59, 4, 4, 208, 4, 38, 38, 59, 83, 83, 37, 4, 4, 13, 48, 39, 39, 40, 40, 13, 39, 38, 40, 196, 13, 13, 13, 13, 13, 13, 14, 88, 48, 91, 48, 48, 14, 100, 88, 192, 91, 14, 14, 14, 14, 14, 14, 17, 100, 52, 52, 124, 189, 95, 52, 17, 108, 111, 17, 17, 95, 122, 122, 108, 111, 188, 122, 128, 128, 144, 144, 152, 139, 139, 17, 18, 52, 139, 124, 147, 147, 152, 145, 18, 155, 156, 18, 18, 145, 145, 157, 185, 156, 178, 155, 165, 165, 167, 167, 139, 157, 173, 18, 25, 25, 195, 195, 203, 25, 155, 195, 195, 173, 25, 197, 197, 202, 203, 206, 204, 210, 210, 177, 202, 161, 206, 218, 218, 25, 204, 25, 26, 26, 217, 217, 142, 26, 141, 217, 217, 136, 26, 219, 219, 221, 221, 225, 225, 134, 221, 221, 132, 130, 127, 125, 121, 26, 116, 26, 60, 60, 113, 110, 104, 101, 92, 77, 60, 60, 60, 60, 60, 60, 61, 61, 73, 69, 66, 61, 64, 63, 58, 49, 47, 61, 42, 28, 27, 16, 15, 9, 6, 5, 0, 0, 0, 0, 0, 0, 0, 61, 151, 151, 0, 0, 0, 0, 0, 0, 151, 151, 151, 151, 151, 151, 0, 0, 151, 153, 153, 0, 0, 0, 153, 0, 0, 0, 0, 0, 153, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 153, 227, 227, 227, 227, 227, 227, 227, 227, 227, 227, 228, 228, 228, 228, 228, 228, 228, 228, 228, 228, 229, 229, 229, 229, 229, 229, 229, 229, 229, 229, 230, 230, 230, 230, 230, 230, 230, 230, 230, 230, 231, 231, 231, 231, 231, 231, 231, 231, 231, 231, 232, 232, 232, 232, 232, 232, 232, 232, 232, 232, 233, 233, 0, 233, 233, 233, 233, 233, 233, 233, 234, 234, 234, 234, 234, 234, 234, 234, 234, 234, 235, 235, 235, 235, 235, 235, 235, 235, 235, 235, 236, 236, 0, 236, 236, 236, 236, 236, 236, 236, 237, 237, 0, 237, 237, 237, 237, 237, 237, 237, 238, 238, 238, 238, 238, 238, 238, 238, 238, 238, 239, 239, 239, 239, 239, 239, 239, 239, 239, 239, 240, 240, 240, 240, 240, 240, 240, 240, 240, 240, 241, 241, 241, 241, 241, 241, 241, 241, 241, 241, 242, 242, 242, 242, 242, 242, 242, 242, 242, 242, 243, 243, 243, 243, 243, 243, 243, 243, 243, 243, 244, 244, 244, 244, 244, 244, 244, 244, 244, 244, 246, 246, 246, 246, 246, 246, 246, 246, 246, 246, 247, 247, 247, 247, 247, 247, 247, 247, 247, 247, 248, 248, 248, 248, 248, 248, 248, 248, 248, 248, 250, 250, 0, 250, 250, 250, 250, 250, 0, 250, 251, 251, 0, 251, 251, 251, 251, 251, 251, 251, 252, 252, 0, 252, 252, 252, 252, 252, 252, 252, 253, 253, 253, 253, 253, 253, 253, 253, 253, 253, 254, 0, 0, 254, 254, 254, 254, 254, 254, 254, 255, 255, 0, 255, 255, 255, 255, 255, 255, 255, 257, 257, 0, 257, 257, 257, 257, 257, 257, 257, 258, 258, 0, 258, 258, 258, 258, 258, 258, 258, 259, 259, 0, 259, 259, 259, 259, 259, 0, 259, 260, 260, 0, 0, 0, 260, 260, 260, 260, 261, 261, 0, 261, 261, 261, 261, 261, 261, 261, 262, 262, 0, 262, 262, 0, 262, 262, 262, 262, 263, 263, 0, 0, 263, 263, 263, 0, 263, 263, 264, 264, 0, 264, 264, 264, 264, 264, 264, 264, 265, 265, 265, 265, 265, 265, 265, 265, 265, 265, 266, 266, 0, 266, 266, 266, 266, 266, 266, 266, 267, 267, 267, 267, 267, 267, 267, 267, 267, 267, 268, 268, 268, 268, 268, 268, 268, 268, 268, 268, 269, 269, 0, 269, 269, 269, 269, 269, 269, 270, 270, 270, 270, 270, 270, 270, 270, 270, 270, 271, 271, 0, 271, 271, 271, 271, 271, 271, 271, 272, 272, 272, 272, 272, 272, 272, 272, 272, 272, 273, 273, 273, 273, 273, 273, 273, 273, 273, 273, 274, 274, 274, 274, 274, 274, 274, 274, 274, 274, 275, 275, 0, 275, 275, 275, 275, 275, 275, 275, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226, 226 } ;/* these declarations have to come after the section 1 code or lint gets * confused about whether the variables are used */FILE *yyin = stdin, *yyout = stdout;/* these variables are all declared out here so that section 3 code can * manipulate them */static int yy_start, yy_b_buf_p, yy_c_buf_p, yy_e_buf_p;static int yy_saw_eof, yy_init = 1;/* yy_ch_buf has to be 1 character longer than YY_BUF_SIZE, since when * setting up yytext we can try to put a '\0' just past the end of the * matched text */#ifdef MALLOC_BUFFERSstatic char *yy_ch_buf = 0L;static int *yy_st_buf = 0L;#elsestatic char yy_ch_buf[YY_BUF_SIZE + 1];static int yy_st_buf[YY_BUF_SIZE];#endifstatic char yy_hold_char;char *yytext;static int yyleng;YY_DECL { int yy_n_chars, yy_lp, yy_iii, yy_buf_pos, yy_act; static int bracelevel, didadef; int i, cclval; char nmdef[MAXLINE], myesc();#ifdef MALLOC_BUFFERS if(yy_ch_buf == 0L){ yy_ch_buf = (char *)malloc(YY_BUF_SIZE + 1); yy_st_buf = (int *)malloc(YY_BUF_SIZE * sizeof(int)); if(yy_ch_buf == 0L || yy_st_buf == 0L){ fprintf( stderr, "Out of memory\n"); exit(-1); } }#endif if ( yy_init ) { YY_INIT; yy_start = 1; yy_init = 0; } goto get_next_token;do_action: for ( ; ; ) { YY_DO_BEFORE_ACTION#ifdef FLEX_DEBUG fprintf( stderr, "--accepting rule #%d\n", yy_act );#endif switch ( yy_act ) {case 1:# line 58 "scan.l"++linenum; ECHO; /* indented code */ YY_BREAKcase 2:# line 59 "scan.l"++linenum; ECHO; /* treat as a comment */ YY_BREAKcase 3:# line 60 "scan.l"ECHO; BEGIN(C_COMMENT); YY_BREAKcase 4:# line 61 "scan.l"return ( SCDECL ); YY_BREAKcase 5:# line 62 "scan.l"return ( XSCDECL ); YY_BREAKcase 6:# line 63 "scan.l"++linenum; line_directive_out( stdout ); BEGIN(CODEBLOCK); YY_BREAKcase 7:# line 64 "scan.l"return ( WHITESPACE ); YY_BREAKcase 8:# line 66 "scan.l"{ sectnum = 2; line_directive_out( stdout ); BEGIN(SECT2PROLOG); return ( SECTEND ); } YY_BREAKcase 9:# line 73 "scan.l"{ fprintf( stderr, "old-style lex command at line %d ignored:\n\t%s", linenum, yytext ); ++linenum; } YY_BREAKcase 10:# line 80 "scan.l"{ (void) strcpy( nmstr, yytext ); didadef = false; BEGIN(PICKUPDE YY_BREAKcase 11:# line 86 "scan.l"RETURNNAME; YY_BREAKcase 12:# line 87 "scan.l"++linenum; /* allows blank lines in section 1 */ YY_BREAKcase 13:# line 88 "scan.l"++linenum; return ( EOL ); YY_BREAKcase 14:# line 89 "scan.l"synerr( "illegal character" ); BEGIN(RECOVER); YY_BREAKcase 15:# line 92 "scan.l"ECHO; BEGIN(0); YY_BREAKcase 16:# line 93 "scan.l"++linenum; ECHO; BEGIN(0); YY_BREAKcase 17:# line 94 "scan.l"ECHO; YY_BREAKcase 18:# line 95 "scan.l"ECHO; YY_BREAKcase 19:# line 96 "scan.l"++linenum; ECHO; YY_BREAKcase 20:# line 98 "scan.l"++linenum; BEGIN(0); YY_BREAKcase 21:# line 99 "scan.l"++linenum; ECHO; YY_BREAKcase 22:# line 101 "scan.l"/* separates name and definition */ YY_BREAKcase 23:# line 103 "scan.l"{ (void) strcpy( nmdef, yytext ); for ( i = strlen( nmdef ) - 1; i >= 0 && nmdef[i] == ' ' || nmdef[i] == '\t'; --i ) ; nmdef[i + 1] = '\0'; ndinstal( nmstr, nmdef ); didadef = true; } YY_BREAKcase 24:# line 118 "scan.l"{ if ( ! didadef ) synerr( "incomplete name definition" ); BEGIN(0); ++linenum; } YY_BREAKcase 25:# line 125 "scan.l"++linenum; BEGIN(0); RETURNNAME; YY_BREAKcase 26:YY_DO_BEFORE_SCAN; /* undo effects of setting up yytext */yy_c_buf_p -= 1;YY_DO_BEFORE_ACTION; /* set up yytext again */# line 128 "scan.l"{ ++linenum; ACTION_ECHO; MARK_END_OF_PROLOG; BEGIN(SECT2); } YY_BREAKcase 27:# line 135 "scan.l"++linenum; ACTION_ECHO; YY_BREAKcase 28:# line 137 "scan.l"++linenum; /* allow blank lines in section 2 */ YY_BREAK /* this horrible mess of a rule matches indented lines which * do not contain "/*". We need to make the distinction because * otherwise this rule will be taken instead of the rule which * matches the beginning of comments like this one */case 29:# line 144 "scan.l"{ synerr( "indented code found outside of action" ); ++linenum; } YY_BREAKcase 30:# line 149 "scan.l"BEGIN(SC); return ( '<' ); YY_BREAKcase 31:# line 150 "scan.l"return ( '^' ); YY_BREAKcase 32:# line 151 "scan.l"BEGIN(QUOTE); return ( '"' ); YY_BREAKcase 33:YY_DO_BEFORE_SCAN; /* undo effects of setting up yytext */yy_c_buf_p = yy_b_buf_p;YY_DO_BEFORE_ACTIet up yytext again */# line 152 "scan.l"BEGIN(NUM); return ( '{' ); YY_BREAKcase 34:# line 153 "scan.l"BEGIN(BRACEERROR); YY_BREAKcase 35:YY_DO_BEFORE_SCAN; /* undo effects of setting up yytext */yy_c_buf_p = yy_b_buf_p;YY_DO_BEFORE_ACTION; /* set up yytext again */# line 154 "scan.l"return ( '$' ); YY_BREAKcase 36:# line 156 "scan.l"{ bracelevel = 1; BEGIN(PERCENT_BRACE_ACTION); return ( EOL ); } YY_BREAKcase 37:# line 161 "scan.l"++linenum; return ( EOL ); YY_BREAKcase 38:# line 163 "scan.l"ACTION_ECHO; BEGIN(C_COMMENT_2); YY_BREAKcase 39:# line 165 "scan.l"{ /* needs to be separate from following rule due to * bug with trailing context */ bracelevel = 0; BEGIN(ACTION); return ( EOL ); } YY_BREAKcase 40:YY_DO_BEFORE_SCAN; /* undo effects of setting up yytext */yy_c_buf_p -= 1;YY_DO_BEFORE_ACTION; /* set up yytext again */# line 173 "scan.l"{ bracelevel = 0; BEGIN(ACTION); return ( EOL ); } YY_BREAKcase 41:# line 179 "scan.l"++linenum; return ( EOL ); YY_BREAKcase 42:# line 181 "scan.l"{ /* guarantee that the SECT3 rule will have something * to match */ yyless(1); sectnum = 3; BEGIN(SECT3); return ( EOF ); /* to stop the parser */ } YY_BREAKcase 43:# line 191 "scan.l"{ (void) strcpy( nmstr, yytext ); /* check to see if we've already encountered this ccl */ if ( (cclval = ccllookup( nmstr )) ) { yylval = cclval; ++cclreuse; return ( PREVCCL ); } else { /* we fudge a bit. We know that this ccl will * soon be numbered as lastccl + 1 by cclinit */ cclinstal( nmstr, lastccl + 1 ); /* push back everything but the leading bracket * so the ccl can be rescanned */ PUT_BACK_STRING(nmstr, 1); BEGIN(FIRSTCCL); return ( '[' ); } } YY_BREAKcase 44:# line 218 "scan.l"{ register char *nmdefptr; char *ndlookup(); (void) strcpy( nmstr, yytext ); nmstr[yyleng - 1] = '\0'; /* chop trailing brace */ /* lookup from "nmstr + 1" to chop leading brace */ if ( ! (nmdefptr = ndlookup( nmstr + 1 )) ) synerr( "undefined {name}" ); else { /* push back name surrounded by ()'s */ unput(')'); PUT_BACK_STRING(nmdefptr, 0); unput('('); } } YY_BREAKcase 45:# line 237 "scan.l"return ( yytext[0] ); YY_BREAKcase 46:# line 238 "scan.l"RETURNCHAR; YY_BREAKcase 47:# line 239 "scan.l"++linenum; return ( EOL ); YY_BREAKcase 48:# line 242 "scan.l"return ( ',' ); YY_BREAKcase 49:# line 243 "scan.l"BEGIN(SECT2); return ( '>' ); YY_BREAKcase 50:YY_DO_BEFORE_SCAN; /* undo effects of setting up yytext */yy_c_buf_p = yy_b_buf_p;YY_DO_BEFORE_ACTION; /* set up yytext again */# line 244 "scan.l"BEGIN(CARETISBOL); return ( '>' ); YY_BREAKcase 51:# line 245 "scan.l"RETURNNAME; YY_BREAKcase 52:# line 246 "scan.l"synerr( "bad start condition name" ); YY_BREAKcase 53:# line 248 "scan.l"BEGIN(SECT2); return ( '^' ); YY_BREAKcase 54:# line 251 "scan.l"RETURNCHAR; YY_BREAKcase 55:# line 252 "scan.l"BEGIN(SECT2); return ( '"' ); YY_BREAKcase 56:# line 254 "scan.l"{ synerr( "missing quote" ); BEGIN(SECT2); ++linenum; return ( '"' ); } YY_BREAKcase 57:YY_DO_BEFORE_SCAN; /* undo effects of setting up yytext */yy_c_buf_p = yy_b_buf_p;YY_DO_BEFORE_ACTION; /* set up yytext again */# line 262 "scan.l"BEGIN(CCL); return ( '^' ); YY_BREAKcase 58:YY_DO_BEFORE_SCAN; /* undo effects of setting up yytext */yy_c_buf_p = yy_b_buf_p;YY_DO_BEFORE_ACTION; /* set up yytext again */# line 263 "scan.l"return ( '^' ); YY_BREAKcase 59:# line 264 "scan.l"BEGIN(CCL); yylval = '-'; return ( CHAR ); YY_BREAKcase 60:# line 265 "scan.l"BEGIN(CCL); RETURNCHAR; YY_BREAKcase 61:YY_DO_BEFORE_SCAN; /* undo effects of setting up yytext */yy_c_buf_p = yy_b_buf_p;YY_DO_BEFORE_ACTION; /* set up yytext again */# line 267 "scan.l"return ( '-' ); YY_BREAKcase 62:# line 268 "scan.l"RETURNCHAR; YY_BREAKcase 63:# line 269 "scan.l"BEGIN(SECT2); return ( ']' ); YY_BREAKcase 64:# line 272 "scan.l"{ yylval = myctoi( yytext ); return ( NUMBER ); } YY_BREAKcase 65:# line 277 "scan.l"return ( ',' ); YY_BREAKcase 66:# line 278 "scan.l"BEGIN(SECT2); return ( '}' ); YY_BREAKcase 67:# line 280 "scan.l"{ synerr( "bad character inside {}'s" ); BEGIN(SECT2); return ( '}' ); } YY_BREAKcase 68:# line 286 "scan.l"{ synerr( "missing }" ); BEGIN(SECT2); ++linenum; return ( '}' ); } YY_BREAKcase 69:# line 294 "scan.l"synerr( "bad name in {}'s" ); BEGIN(SECT2); YY_BREAKcase 70:# line 295 "scan.l"synerr( "missing }" ); ++linenum; BEGIN(SECT2); YY_BREAKcase 71:# line 298 "scan.l"bracelevel = 0; YY_BREAKcase 72:# line 299 "scan.l"ACTION_ECHO; YY_BREAKcase 73:# line 300 "scan.l"{ ++linenum; ACTION_ECHO; if ( bracelevel == 0 ) { fputs( "\tYY_BREAK\n", temp_action_file ); BEGIN(SECT2); } } YY_BREAKcase 74:# line 310 "scan.l"ACTION_ECHO; ++bracelevel; YY_BREAKcase 75:# line 311 "scan.l"ACTION_ECHO; --bracelevel; YY_BREAKcase 76:# line 312 "scan.l"ACTION_ECHO; YY_BREAKcase 77:# line 313 "scan.l"ACTION_ECHO; BEGIN(ACTION_COMMENT); YY_BREAKcase 78:# line 314 "scan.l"ACTION_ECHO; /* character constant */ YY_BREAKcase 79:# line 315 "scan.l"ACTION_ECHO; BEGIN(ACTION_STRING); YY_BREAKcase 80:# line 316 "scan.l"{ ++linenum; ACTION_ECHO; if ( bracelevel == 0 ) { fputs( "\tYY_BREAK\n", temp_action_file ); BEGIN(SECT2); } } YY_BREAKcase 81:# line 325 "scan.l"ACTION_
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:flex ƒ:scan.c.dist
+++++ Continued from previous card +++++
ECHO; YY_BREAKcase 82:# line 327 "scan.l"ACTION_ECHO; BEGIN(ACTION); YY_BREAKcase 83:# line 328 "scan.l"ACTION_ECHO; YY_BREAKcase 84:# line 329 "scan.l"ACTION_ECHO; YY_BREAKcase 85:# line 330 "scan.l"++linenum; ACTION_ECHO; YY_BREAKcase 86:# line 331 "scan.l"ACTION_ECHO; YY_BREAKcase 87:# line 333 "scan.l"ACTION_ECHO; BEGIN(SECT2); YY_BREAKcase 88:# line 334 "scan.l"++linenum; ACTION_ECHO; BEGIN(SECT2); YY_BREAKcase 89:# line 335 "scan.l"ACTION_ECHO; YY_BREAKcase 90:# line 336 "scan.l"ACTION_ECHO; YY_BREAKcase 91:# line 337 "scan.l"++linenum; ACTION_ECHO; YY_BREAKcase 92:# line 339 "scan.l"ACTION_ECHO; YY_BREAKcase 93:# line 340 "scan.l"ACTION_ECHO; YY_BREAKcase 94:# line 341 "scan.l"++linenum; ACTION_ECHO; YY_BREAKcase 95:# line 342 "scan.l"ACTION_ECHO; BEGIN(ACTION); YY_BREAKcase 96:# line 343 "scan.l"ACTION_ECHO; YY_BREAKcase 97:# line 346 "scan.l"{ yylval = myesc( yytext ) & BYTEMASK; return ( CHAR ); } YY_BREAKcase 98:# line 351 "scan.l"{ yylval = myesc( yytext ) & BYTEMASK; BEGIN(CCL); return ( CHAR ); } YY_BREAKcase 99:# line 358 "scan.l"{ register int numchars; /* black magic - we know the names of a flex scanner's * internal variables. We cap the input buffer with * an end-of-string and dump it to the output. */ YY_DO_BEFORE_SCAN; /* recover from setting up yytext */#ifdef FLEX_FAST_SKEL fputs( yy_c_buf_p + 1, stdout );#else yy_ch_buf[yy_e_buf_p + 1] = '\0'; /* ignore the first character; it's the second '%' * put back by the yyless(1) above */ fputs( yy_ch_buf + yy_c_buf_p + 1, stdout );#endif /* if we don't do this, the data written by write() * can get overwritten when stdout is finally flushed */ (void) fflush( stdout ); while ( (numchars = read( fileno(yyin), yy_ch_buf, YY_BUF_MAX )) > 0 ) (void) write( fileno(stdout), yy_ch_buf, numchars ); if ( numchars < 0 ) flexerror( "fatal read error in section 3" ); return ( EOF ); } YY_BREAKcase YY_NEW_FILE:break; /* begin reading from new file */case YY_DO_DEFAULT:YY_DEFAULT_ACTION;break;case YY_END_TOK:return ( YY_END_TOK );default:YY_FATAL_ERROR( "fatal flex scanner internal error" ); }get_next_token: { register int yy_curst; register char yy_sym; YY_DO_BEFORE_SCAN /* set up to begin running DFA */ yy_curst = yy_start; if ( yy_ch_buf[yy_c_buf_p] == EOLCHAR ) ++yy_curst; /* yy_b_buf_p points to the position in yy_ch_buf * of the start of the current run. */ yy_b_buf_p = yy_c_buf_p + 1; do /* until the machine jams */ { if ( yy_c_buf_p == yy_e_buf_p ) { /* need more input */ if ( yy_e_buf_p >= YY_BUF_LIM ) { /* not enough room to do another read */ /* see if we can make some room for more chars */ yy_n_chars = yy_e_buf_p - yy_b_buf_p; if ( yy_n_chars >= 0 ) /* shift down buffer to make room */ for ( yy_iii = 0; yy_iii <= yy_n_chars; ++yy_iii ) { yy_buf_pos = yy_b_buf_p + yy_iii; yy_ch_buf[yy_iii] = yy_ch_buf[yy_buf_pos]; yy_st_buf[yy_iii] = yy_st_buf[yy_buf_pos]; } yy_b_buf_p = 0; yy_e_buf_p = yy_n_chars; if ( yy_e_buf_p >= YY_BUF_LIM ) YY_FATAL_ERROR( "flex input buffer overflowed" ); yy_c_buf_p = yy_e_buf_p; } else if ( yy_saw_eof ) {saweof: if ( yy_b_buf_p > yy_e_buf_p ) { if ( yywrap() ) { yy_act = YY_END_TOK; goto do_action; } else { YY_INIT; yy_act = YY_NEW_FILE; goto do_action; } } else /* do a jam to eat up more input */ {#ifndef FLEX_INTERACTIVE_SCANNER /* we're going to decrement yy_c_buf_p upon doing * the jam. In this case, that's wrong, since * it points to the last non-jam character. So * we increment it now to counter the decrement. */ ++yy_c_buf_p;#endif break; } } YY_INPUT( (yy_ch_buf + yy_c_buf_p + 1), yy_n_chars, YY_MAX_LINE ); if ( yy_n_chars == YY_NULL ) { if ( yy_saw_eof ) YY_FATAL_ERROR( "flex scanner saw EOF twice - shouldn't happen" ); yy_saw_eof = 1; goto saweof; } yy_e_buf_p += yy_n_chars; } ++yy_c_buf_p;#ifdef FLEX_USE_ECS yy_sym = e[(yy_ch_buf[yy_c_buf_p] & BYTEMASK)];#else yy_sym = yy_ch_buf[yy_c_buf_p];#endif#ifdef FLEX_FULL_TABLE yy_curst = n[yy_curst][yy_sym];#else /* get next state from compressed table */ while ( c[b[yy_curst] + yy_sym] != yy_curst ) { yy_curst = d[yy_curst];#ifdef FLEX_USE_MECS /* we've arrange it so that templates are never chained * to one another. This means we can afford make a * very simple test to see if we need to convert to * yy_sym's meta-equivalence class without worrying * about erroneously looking up the meta-eqe * class twice */ if ( yy_curst >= YY_TEMPLATE ) yy_sym = m[yy_sym];#endif } yy_curst = n[b[yy_curst] + yy_sym];#endif yy_st_buf[yy_c_buf_p] = yy_curst; }#ifdef FLEX_INTERACTIVE_SCANNER while ( b[yy_curst] != YY_JAM_BASE );#else while ( yy_curst != YY_JAM ); --yy_c_buf_p; /* put back character we jammed on */#endif if ( yy_c_buf_p >= yy_b_buf_p ) { /* we matched some text */ yy_curst = yy_st_buf[yy_c_buf_p]; yy_lp = l[yy_curst];#ifdef FLEX_REJECT_ENABLEDfind_rule: /* we branch to this label when doing a REJECT */#endif for ( ; ; ) /* until we find what rule we matched */ {#ifdef FLEX_REJECT_ENABLED if ( yy_lp && yy_lp < l[yy_curst + 1] ) { yy_act = a[yy_lp]; goto do_action; /* "continue 2" */ }#else if ( yy_lp ) { yy_act = yy_lp; goto do_action; /* "continue 2" */ }#endif if ( --yy_c_buf_p < yy_b_buf_p ) break; yy_curst = yy_st_buf[yy_c_buf_p]; yy_lp = l[yy_curst]; } } /* if we got this far, then we didn't find any accepting * states */ /* so that the default applies to the first char read */ ++yy_c_buf_p; yy_act = YY_DO_DEFAULT; } } /*NOTREACHED*/ }static int unput( c )char c; { YY_DO_BEFORE_SCAN; /* undo effects of setting up yytext */ if ( yy_c_buf_p == 0 ) { register int i; register int yy_buf_pos = YY_BUF_MAX; for ( i = yy_e_buf_p; i >= yy_c_buf_p; --i ) { yy_ch_buf[yy_buf_pos] = yy_ch_buf[i]; yy_st_buf[yy_buf_pos] = yy_st_buf[i]; --yy_buf_pos; } yy_c_buf_p = YY_BUF_MAX - yy_e_buf_p; yy_e_buf_p = YY_BUF_MAX; } if ( yy_c_buf_p <= 0 ) YY_FATAL_ERROR( "flex scanner push-back overflow" ); if ( yy_c_buf_p >= yy_b_buf_p && yy_ch_buf[yy_c_buf_p] == EOLCHAR ) yy_ch_buf[yy_c_buf_p - 1] = EOLCHAR; yy_ch_buf[yy_c_buf_p--] = c; YY_DO_BEFORE_ACTION; /* set up yytext again */ }static int input() { int c; YY_DO_BEFORE_SCAN if ( yy_c_buf_p == yy_e_buf_p ) { /* need more input */ int yy_n_chars; /* we can throw away the entire current buffer */ if ( yy_saw_eof ) { if ( yywrap() ) return ( EOF ); YY_INIT; } yy_b_buf_p = 0; YY_INPUT( yy_ch_buf, yy_n_chars, YY_MAX_LINE ); if ( yy_n_chars == YY_NULL ) { yy_saw_eof = 1; if ( yywrap() ) return ( EOF ); YY_INIT; return ( input() ); } yy_c_buf_p = -1; yy_e_buf_p = yy_n_chars - 1; } c = yy_ch_buf[++yy_c_buf_p]; YY_DO_BEFORE_ACTION; return ( c & BYTEMASK); }# line 392 "scan.l" :MPW:MPW Tools:Tools with Source:flex ƒ:scan.l
/* scan.l - scanner for flex input *//* * Copyright (c) 1987, the University of California * * The United States Government has rights in this work pursuant to * contract no. DE-AC03-76SF00098 between the United States Department of * Energy and the University of California. * * This program may be redistributed. Enhancements and derivative works * may be created provided the new works, if made available to the general * public, are made available for use by anyone. */%{#include "flexdef.h"#include "parse.h"#ifdef macintosh#pragma segment _other2#endif#define ACTION_ECHO fprintf( temp_action_file, "%s", yytext )#define MARK_END_OF_PROLOG fprintf( temp_action_file, "%%%% end of prolog\n" );#undef YY_DECL#define YY_DECL \ int flexscan()#define RETURNCHAR \ yylval = yytext[0] & BYTEMASK; \ return ( CHAR );#define RETURNNAME \ (void) strcpy( nmstr, yytext ); \ return ( NAME );#define PUT_BACK_STRING(str, start) \ for ( i = strlen( str ) - 1; i >= start; --i ) \ unput(str[i])%}%x SECT2 SECT2PROLOG SECT3 CODEBLOCK PICKUPDEF SC CARETISBOL NUM QUOTE%x FIRSTCCL CCL ACTION RECOVER BRACEERROR C_COMMENT C_COMMENT_2 ACTION_COMMENT%x ACTION_STRING PERCENT_BRACE_ACTIONWS [ \t]+OPTWS [ \t]*NAME [a-z_][a-z_0-9]*SCNAME {NAME}ESCSEQ \\([^^\n]|"^".|0[0-9]{1,3})%% static int bracelevel, didadef; int i, cclval; char nmdef[MAXLINE], myesc();^{WS}.*\n ++linenum; ECHO; /* indented code */^#.*\n ++linenum; ECHO; /* treat as a comment */^"/*" ECHO; BEGIN(C_COMMENT);^"%s"(tart)? return ( SCDECL );^"%x" return ( XSCDECL );^"%{".*\n ++linenum; line_directive_out( stdout ); BEGIN(CODEBLOCK);{WS} return ( WHITESPACE );^"%%".* { sectnum = 2; line_directive_out( stdout ); BEGIN(SECT2PROLOG); return ( SECTEND ); }^"%"[^sx{%].*\n { fprintf( stderr, "old-style lex command at line %d ignored:\n\t%s", linenum, yytext ); ++linenum; }^{NAME} { (void) strcpy( nmstr, yytext ); didadef = false; BEGIN(PICKUPDEF); }{SCNAME} RETURNNAME;^{OPTWS}\n ++linenum; /* allows blank lines in section 1 */\n ++linenum; return ( EOL );. synerr( "illegal character" ); BEGIN(RECOVER);<C_COMMENT>"*/" ECHO; BEGIN(0);<C_COMMENT>"*/".*\n ++linenum; ECHO; BEGIN(0);<C_COMMENT>[^*\n]+ ECHO;<C_COMMENT>"*" ECHO;<C_COMMENT>\n ++linenum; ECHO;<CODEBLOCK>^"%}".*\n ++linenum; BEGIN(0);<CODEBLOCK>.*\n ++linenum; ECHO;<PICKUPDEF>{WS} /* separates name and definition */<PICKUPDEF>[^ \t\n].* { (void) strcpy( nmdef, yytext ); for ( i = strlen( nmdef ) - 1; i >= 0 && nmdef[i] == ' ' || nmdef[i] == '\t'; --i ) ; nmdef[i + 1] = '\0'; ndinstal( nmstr, nmdef ); didadef = true; }<PICKUPDEF>\n { if ( ! didadef ) synerr( "incomplete name definition" ); BEGIN(0); ++linenum; }<RECOVER>.*\n ++linenum; BEGIN(0); RETURNNAME;<SECT2PROLOG>.*\n/[^ \t\n] { ++linenum; ACTION_ECHO; MARK_END_OF_PROLOG; BEGIN(SECT2); }<SECT2PROLOG>.*\n ++linenum; ACTION_ECHO;<SECT2>^{OPTWS}\n ++linenum; /* allow blank lines in section 2 */ /* this horrible mess of a rule matches indented lines which * do not contain "/*". We need to make the distinction because * otherwise this rule will be taken instead of the rule which * matches the beginning of comments like this one */<SECT2>^{WS}([^/\n]|"/"[^*\n])*("/"?)\n { synerr( "indented code found outside of action" ); ++linenum; }<SECT2>"<" BEGIN(SC); return ( '<' );<SECT2>^"^" return ( '^' );<SECT2>\" BEGIN(QUOTE); return ( '"' );<SECT2>"{"/[0-9] BEGIN(NUM); return ( '{' );<SECT2>"{"[^0-9\n][^}\n]* BEGIN(BRACEERROR);<SECT2>"$"/[ \t\n] return ( '$' );<SECT2>{WS}"%{" { bracelevel = 1; BEGIN(PERCENT_BRACE_ACTION); return ( EOL ); }<SECT2>{WS}"|".*\n ++linenum; return ( EOL );<SECT2>^{OPTWS}"/*" ACTION_ECHO; BEGIN(C_COMMENT_2);<SECT2>{WS} { /* needs to be separate from following rule due to * bug with trailing context */ bracelevel = 0; BEGIN(ACTION); return ( EOL ); }<SECT2>{OPTWS}/\n { bracelevel = 0; BEGIN(ACTION); return ( EOL ); }<SECT2>^{OPTWS}\n ++linenum; return ( EOL );<SECT2>^"%%".* { /* guarantee that the SECT3 rule will have something * to match */ yyless(1); sectnum = 3; BEGIN(SECT3); return ( EOF ); /* to stop the parser */ }<SECT2>"["([^\\\]\n]|{ESCSEQ})+"]" { (void) strcpy( nmstr, yytext ); /* check to see if we've already encountered this ccl */ if ( (cclval = ccllookup( nmstr )) ) { yylval = cclval; ++cclreuse; return ( PREVCCL ); } else { /* we fudge a bit. We know that this ccl will * soon be numbered as lastccl + 1 by cclinit */ cclinstal( nmstr, lastccl + 1 ); /* push back everything but the leading bracket * so the ccl can be rescanned */ PUT_BACK_STRING(nmstr, 1); BEGIN(FIRSTCCL); return ( '[' ); } }<SECT2>"{"{NAME}"}" { register char *nmdefptr; char *ndlookup(); (void) strcpy( nmstr, yytext ); nmstr[yyleng - 1] = '\0'; /* chop trailing brace */ /* lookup from "nmstr + 1" to chop leading brace */ if ( ! (nmdefptr = ndlookup( nmstr + 1 )) ) synerr( "undefined {name}" ); else { /* push back name surrounded by ()'s */ unput(')'); PUT_BACK_STRING(nmdefptr, 0); unput('('); } }<SECT2>[/|*+?.()] return ( yytext[0] );<SECT2>. RETURNCHAR;<SECT2>\n ++linenum; return ( EOL );<SC>"," return ( ',' );<SC>">" BEGIN(SECT2); return ( '>' );<SC>">"/"^" BEGIN(CARETISBOL); return ( '>' );<SC>{SCNAME} RETURNNAME;<SC>. synerr( "bad start condition name" );<CARETISBOL>"^" BEGIN(SECT2); return ( '^' );<QUOTE>[^"\n] RETURNCHAR;<QUOTE>\" BEGIN(SECT2); return ( '"' );<QUOTE>\n { synerr( "missing quote" ); BEGIN(SECT2); ++linenum; return ( '"' ); }<FIRSTCCL>"^"/[^-\n] BEGIN(CCL); return ( '^' );<FIRSTCCL>"^"/- return ( '^' );<FIRSTCCL>- BEGIN(CCL); yylval = '-'; return ( CHAR );<FIRSTCCL>. BEGIN(CCL); RETURNCHAR;<CCL>-/[^\]\n] return ( '-' );<CCL>[^\]\n] RETURNCHAR;<CCL>"]" BEGIN(SECT2); return ( ']' );<NUM>[0-9]+ { yylval = myctoi( yytext ); return ( NUMBER ); }<NUM>"," return ( ',' );<NUM>"}" BEGIN(SECT2); return ( '}' );<NUM>. { synerr( "bad character inside {}'s" ); BEGIN(SECT2); return ( '}' ); }<NUM>\n { synerr( "missing }" ); BEGIN(SECT2); ++linenum; return ( '}' ); }<BRACEERROR>"}" synerr( "bad name in {}'s" ); BEGIN(SECT2);<BRACEERROR>\n synerr( "missing }" ); ++linenum; BEGIN(SECT2);<PERCENT_BRACE_ACTION>{OPTWS}"%}".* bracelevel = 0;<PERCENT_BRACE_ACTION>.* ACTION_ECHO;<PERCENT_BRACE_ACTION>\n { ++linenum; ACTION_ECHO; if ( bracelevel == 0 ) { fputs( "\tYY_BREAK\n", temp_action_file ); BEGIN(SECT2); } }<ACTION>"{" ACTION_ECHO; ++bracelevel;<ACTION>"}" ACTION_ECHO; --bracelevel;<ACTION>[^{}"'/\n]+ ACTION_ECHO;<ACTION>"/*" ACTION_ECHO; BEGIN(ACTION_COMMENT);<ACTION>"'"([^'\\\n]|\\.)*"'" ACTION_ECHO; /* character constant */<ACTION>\" ACTION_ECHO; BEGIN(ACTION_STRING);<ACTION>\n { ++linenum; ACTION_ECHO; if ( bracelevel == 0 ) { fputs( "\tYY_BREAK\n", temp_action_file ); BEGIN(SECT2); } }<ACTION>. ACTION_ECHO;<ACTION_COMMENT>"*/" ACTION_ECHO; BEGIN(ACTION);<ACTION_COMMENT>[^*\n]+ ACTION_ECHO;<ACTION_COMMENT>"*" ACTION_ECHO;<ACTION_COMMENT>\n ++linenum; ACTION_ECHO;<ACTION_COMMENT>. ACTION_ECHO;<C_COMMENT_2>"*/" ACTION_ECHO; BEGIN(SECT2);<C_COMMENT_2>"*/".*\n ++linenum; ACTION_ECHO; BEGIN(SECT2);<C_COMMENT_2>[^*\n]+ ACTION_ECHO;<C_COMMENT_2>"*" ACTION_ECHO;<C_COMMENT_2>\n ++linenum; ACTION_ECHO;<ACTION_STRING>[^"\\\n]+ ACTION_ECHO;<ACTION_STRING>\\. ACTION_ECHO;<ACTION_STRING>\n ++linenum; ACTION_ECHO;<ACTION_STRING>\" ACTION_ECHO; BEGIN(ACTION);<ACTION_STRING>. ACTION_ECHO;<SECT2,QUOTE,CCL>{ESCSEQ} { yylval = myesc( yytext ) & BYTEMASK; return ( CHAR ); }<FIRSTCCL>{ESCSEQ} { yylval = myesc( yytext ) & BYTEMASK; BEGIN(CCL); return ( CHAR ); }<SECT3>.|\n { register int numchars; /* black magic - we know the names of a flex scanner's * internal variables. We cap the input buffer with * an end-of-string and dump it to the output. */ YY_DO_BEFORE_SCAN; /* recover from setting up yytext */#ifdef FLEX_FAST_SKEL fputs( yy_c_buf_p + 1, stdout );#else yy_ch_buf[yy_e_buf_p + 1] = '\0'; /* ignore the first character; it's the second '%' * put back by the yyless(1) above */ fputs( yy_ch_buf + yy_c_buf_p + 1, stdout );#endif /* if we don't do this, the data written by write() * can get overwritten when stdout is finally flushed */ (void) fflush( stdout ); while ( (numchars = read( fileno(yyin), yy_ch_buf, YY_BUF_MAX )) > 0 ) (void) write( fileno(stdout), yy_ch_buf, numchars ); if ( numchars < 0 ) flexerror( "fatal read error in section 3" ); return ( EOF ); }%% :MPW:MPW Tools:Tools with Source:flex ƒ:sym.c
/* sym - symbol table routines *//* * Copyright (c) 1987, the University of California * * The United States Government has rights in this work pursuant to * contract no. DE-AC03-76SF00098 between the United States Department of * Energy and the University of California. * * This program may be redistributed. Enhancements and derivative works * may be created provided the new works, if made available to the general * public, are made available for use by anyone. */#include "flexdef.h"/* * MPW C 2.0.2 does not like variables named "entry". */#ifdef macintosh#define entry entry_by_another_name#pragma segment _other#endifstruct hash_entry *ndtbl[NAME_TABLE_HASH_SIZE];struct hash_entry *sctbl[START_COND_HASH_SIZE];struct hash_entry *ccltab[CCL_HASH_SIZE];struct hash_entry *findsym();/* addsym - add symbol and definitions to symbol table * * synopsis * char sym[], *str_def; * int int_def; * hash_table table; * int table_size; * 0 / -1 = addsym( sym, def, int_def, table, table_size ); * * -1 is returned if the symbol already exists, and the change not made. */int addsym( sym, str_def, int_def, table, table_size )register char sym[];char *str_def;int int_def;hash_table table;int table_size; { int hash_val = hashfunct( sym, table_size ); register struct hash_entry *entry = table[hash_val]; register struct hash_entry *new_entry; register struct hash_entry *successor; char *malloc(); while ( entry ) { if ( ! strcmp( sym, entry->name ) ) { /* entry already exists */ return ( -1 ); } entry = entry->next; } /* create new entry */ new_entry = (struct hash_entry *) malloc( sizeof( struct hash_entry ) ); if ( new_entry == NULL ) flexfatal( "symbol table memory allocation failed" ); if ( (successor = table[hash_val]) ) { new_entry->next = successor; successor->prev = new_entry; } else new_entry->next = NULL; new_entry->prev = NULL; new_entry->name = sym; new_entry->str_val = str_def; new_entry->int_val = int_def; table[hash_val] = new_entry; return ( 0 ); }/* cclinstal - save the text of a character class * * synopsis * char ccltxt[]; * int cclnum; * cclinstal( ccltxt, cclnum ); */cclinstal( ccltxt, cclnum )char ccltxt[];int cclnum; { /* we don't bother checking the return status because we are not called * unless the symbol is new */ char *copy_string(); (void) addsym( copy_string( ccltxt ), (char *) 0, cclnum, ccltab, CCL_HASH_SIZE ); }/* ccllookup - lookup the number associated with character class text * * synopsis * char ccltxt[]; * int ccllookup, cclval; * cclval/0 = ccllookup( ccltxt ); */int ccllookup( ccltxt )char ccltxt[]; { return ( findsym( ccltxt, ccltab, CCL_HASH_SIZE )->int_val ); }/* findsym - find symbol in symbol table * * synopsis * char sym[]; * hash_table table; * int table_size; * struct hash_entry *entry, *findsym(); * entry = findsym( sym, table, table_size ); */struct hash_entry *findsym( sym, table, table_size )register char sym[];hash_table table;int table_size; { register struct hash_entry *entry = table[hashfunct( sym, table_size )]; static struct hash_entry empty_entry = { (struct hash_entry *) 0, (struct hash_entry *) 0, NULL, NULL, 0, } ; while ( entry ) { if ( ! strcmp( sym, entry->name ) ) return ( entry ); entry = entry->next; } return ( &empty_entry ); } /* hashfunct - compute the hash value for "str" and hash size "hash_size" * * synopsis * char str[]; * int hash_size, hash_val; * hash_val = hashfunct( str, hash_size ); */int hashfunct( str, hash_size )register char str[];int hash_size; { register int hashval; register int locstr; hashval = 0; locstr = 0; while ( str[locstr] ) hashval = ((hashval << 1) + str[locstr++]) % hash_size; return ( hashval ); }/* ndinstal - install a name definition * * synopsis * char nd[], def[]; * ndinstal( nd, def ); */ndinstal( nd, def )char nd[], def[]; { char *copy_string(); if ( addsym( copy_string( nd ), copy_string( def ), 0, ndtbl, NAME_TABLE_HASH_SIZE ) ) synerr( "name defined twice" ); }/* ndlookup - lookup a name definition * * synopsis * char nd[], *def; * char *ndlookup(); * def/NULL = ndlookup( nd ); */char *ndlookup( nd )char nd[]; { return ( findsym( nd, ndtbl, NAME_TABLE_HASH_SIZE )->str_val ); }/* scinstal - make a start condition * * synopsis * char str[]; * int xcluflg; * scinstal( str, xcluflg ); * * NOTE * the start condition is Exclusive if xcluflg is true */scinstal( str, xcluflg )char str[];int xcluflg; { char *copy_string(); /* bit of a hack. We know how the default start-condition is * declared, and don't put out a define for it, because it * would come out as "#define 0 1" */ /* actually, this is no longer the case. The default start-condition * is now called "INITIAL". But we keep the following for the sake * of future robustness. */ if ( strcmp( str, "0" ) ) printf( "#define %s %d\n", str, lastsc * 2 ); if ( ++lastsc >= current_max_scs ) { current_max_scs += MAX_SCS_INCREMENT; ++num_reallocs; scset = reallocate_integer_array( scset, current_max_scs ); scbol = reallocate_integer_array( scbol, current_max_scs ); scxclu = reallocate_integer_array( scxclu, current_max_scs ); actvsc = reallocate_integer_array( actvsc, current_max_scs ); } if ( addsym( copy_string( str ), (char *) 0, lastsc, sctbl, START_COND_HASH_SIZE ) ) lerrsf( "start condition %s declared twice", str ); scset[lastsc] = mkstate( SYM_EPSILON ); scbol[lastsc] = mkstate( SYM_EPSILON ); scxclu[lastsc] = xcluflg; }/* sclookup - lookup the number associated with a start condition * * synopsis * char str[], scnum; * int sclookup; * scnum/0 = sclookup( str ); */int sclookup( str )char str[]; { return ( findsym( str, sctbl, START_COND_HASH_SIZE )->int_val ); } :MPW:MPW Tools:Tools with Source:flex ƒ:tblcmp.c
/* tblcmp - table compression routines *//* * Copyright (c) 1987, the University of California * * The United States Government has rights in this work pursuant to * contract no. DE-AC03-76SF00098 between the United States Department of * Energy and the University of California. * * This program may be redistributed. Enhancements and derivative works * may be created provided the new works, if made available to the general * public, are made available for use by anyone. */#include "flexdef.h"/* bldtbl - build table entries for dfa state * * synopsis * int state[numecs], statenum, totaltrans, comstate, comfreq; * bldtbl( state, statenum, totaltrans, comstate, comfreq ); * * State is the statenum'th dfa state. It is indexed by equivalence class and * gives the number of the state to enter for a given equivalence class. * totaltrans is the total number of transitions out of the state. Comstate * is that state which is the destination of the most transitions out of State. * Comfreq is how many transitions there are out of State to Comstate. * * A note on terminology: * "protos" are transition tables which have a high probability of * either being redundant (a state processed later will have an identical * transition table) or nearly redundant (a state processed later will have * many of the same out-transitions). A "most recently used" queue of * protos is kept around with the hope that most states will find a proto * which is similar enough to be usable, and therefore compacting the * output tables. * "templates" are a special type of proto. If a transition table is * homogeneous or nearly homogeneous (all transitions go to the same * destination) then the odds are good that future states will also go * to the same destination state on basically the same character set. * These homogeneous states are so common when dealing with large rule * sets that they merit special attention. If the transition table were * simply made into a proto, then (typically) each subsequent, similar * state will differ from the proto for two out-transitions. One of these * out-transitions will be that character on which the proto does not go * to the common destination, and one will be that character on which the * state does not go to the common destination. Templates, on the other * hand, go to the common state on EVERY transition character, and therefore * cost only one difference. */bldtbl( state, statenum, totaltrans, comstate, comfreq )int state[], statenum, totaltrans, comstate, comfreq; { int extptr, extrct[2][CSIZE + 1]; int mindiff, minprot, i, d; int checkcom; /* If extptr is 0 then the first array of extrct holds the result of the * "best difference" to date, which is those transitions which occur in * "state" but not in the proto which, to date, has the fewest differences * between itself and "state". If extptr is 1 then the second array of * extrct hold the best difference. The two arrays are toggled * between so that the best difference to date can be kept around and * also a difference just created by checking against a candidate "best" * proto. */ extptr = 0; /* if the state has too few out-transitions, don't bother trying to * compact its tables */ if ( (totaltrans * 100) < (numecs * PROTO_SIZE_PERCENTAGE) ) mkentry( state, numecs, statenum, JAMSTATE, totaltrans ); else { /* checkcom is true if we should only check "state" against * protos which have the same "comstate" value */ checkcom = comfreq * 100 > totaltrans * CHECK_COM_PERCENTAGE; minprot = firstprot; mindiff = totaltrans; if ( checkcom ) { /* find first proto which has the same "comstate" */ for ( i = firstprot; i != NIL; i = protnext[i] ) if ( protcomst[i] == comstate ) { minprot = i; mindiff = tbldiff( state, minprot, extrct[extptr] ); break; } } else { /* since we've decided that the most common destination out * of "state" does not occur with a high enough frequency, * we set the "comstate" to zero, assuring that if this state * is entered into the proto list, it will not be considered * a template. */ comstate = 0; if ( firstprot != NIL ) { minprot = firstprot; mindiff = tbldiff( state, minprot, extrct[extptr] ); } } /* we now have the first interesting proto in "minprot". If * it matches within the tolerances set for the first proto, * we don't want to bother scanning the rest of the proto list * to see if we have any other reasonable matches. */ if ( mindiff * 100 > totaltrans * FIRST_MATCH_DIFF_PERCENTAGE ) { /* not a good enough match. Scan the rest of the protos */ for ( i = minprot; i != NIL; i = protnext[i] ) { d = tbldiff( state, i, extrct[1 - extptr] ); if ( d < mindiff ) { extptr = 1 - extptr; mindiff = d; minprot = i; } } } /* check if the proto we've decided on as our best bet is close * enough to the state we want to match to be usable */ if ( mindiff * 100 > totaltrans * ACCEPTABLE_DIFF_PERCENTAGE ) { /* no good. If the state is homogeneous enough, we make a * template out of it. Otherwise, we make a proto. */ if ( comfreq * 100 >= totaltrans * TEMPLATE_SAME_PERCENTAGE ) mktemplate( state, statenum, comstate ); else { mkprot( state, statenum, comstate ); mkentry( state, numecs, statenum, JAMSTATE, totaltrans ); } } else { /* use the proto */ mkentry( extrct[extptr], numecs, statenum, prottbl[minprot], mindiff ); /* if this state was sufficiently different from the proto * we built it from, make it, too, a proto */ if ( mindiff * 100 >= totaltrans * NEW_PROTO_DIFF_PERCENTAGE ) mkprot( state, statenum, comstate ); /* since mkprot added a new proto to the proto queue, it's possible * that "minprot" is no longer on the proto queue (if it happened * to have been the last entry, it would have been bumped off). * If it's not there, then the new proto took its physical place * (though logically the new proto is at the beginning of the * queue), so in that case the following call will do nothing. */ mv2front( minprot ); } } }/* cmptmps - compress template table entries * * synopsis * cmptmps(); * * template tables are compressed by using the 'template equivalence * classes', which are collections of transition character equivalence * classes which always appear together in templates - really meta-equivalence * classes. until this point, the tables for templates have been stored * up at the top end of the nxt array; they will now be compressed and have * table entries made for them. */cmptmps() { int tmpstorage[CSIZE + 1]; register int *tmp = tmpstorage, i, j; int totaltrans, trans; peakpairs = numtemps * numecs + tblend; if ( usemecs ) { /* create equivalence classes base on data gathered on template * transitions */ nummecs = cre8ecs( tecfwd, tecbck, numecs ); } else nummecs = numecs; if ( lastdfa + numtemps + 1 >= current_max_dfas ) increase_max_dfas(); /* loop through each template */ for ( i = 1; i <= numtemps; ++i ) { totaltrans = 0; /* number of non-jam transitions out of this template */ for ( j = 1; j <= numecs; ++j ) { trans = tnxt[numecs * i + j]; if ( usemecs ) { /* the absolute value of tecbck is the meta-equivalence class * of a given equivalence class, as set up cs */ if ( tecbck[j] > 0 ) { tmp[tecbck[j]] = trans; if ( trans > 0 ) ++totaltrans; } } else { tmp[j] = trans; if ( trans > 0 ) ++totaltrans; } } /* it is assumed (in a rather subtle way) in the skeleton that * if we're using meta-equivalence classes, the def[] entry for * all templates is the jam template, i.e., templates never default * to other non-jam table entries (e.g., another template) */ /* leave room for the jam-state after the last real state */ mkentry( tmp, nummecs, lastdfa + i + 1, JAMSTATE, totaltrans ); } }/* expand_nxt_chk - expand the next check arrays */expand_nxt_chk() { register int old_max = current_max_xpairs; current_max_xpairs += MAX_XPAIRS_INCREMENT; ++num_reallocs; nxt = reallocate_integer_array( nxt, current_max_xpairs ); chk = reallocate_integer_array( chk, current_max_xpairs ); bzero( (char *) (chk + old_max), MAX_XPAIRS_INCREMENT * sizeof( int ) / sizeof( char ) ); }/* find_table_space - finds a space in the table for a state to be placed * * synopsis * int *state, numtrans, block_start; * int find_table_space(); * * block_start = find_table_space( state, numtrans ); * * State is the state to be added to the full speed transition table. * Numtrans is the number of out-transitions for the state. * * find_table_space() returns the position of the start of the first block (in * chk) able to accommodate the state * * In determining if a state will or will not fit, find_table_space() must take * into account the fact that an end-of-buffer state will be added at [0], * and an action number will be added in [-1]. */int find_table_space( state, numtrans )int *state, numtrans; { /* firstfree is the position of the first possible occurrence of two * consecutive unused records in the chk and nxt arrays */ register int i; register int *state_ptr, *chk_ptr; register int *ptr_to_last_entry_in_state; /* if there are too many out-transitions, put the state at the end of * nxt and chk */ if ( numtrans > MAX_XTIONS_FOR_FULL_INTERIOR_FIT ) { /* if table is empty, return the first available spot in chk/nxt, * which should be 1 */ if ( tblend < 2 ) return ( 1 ); i = tblend - numecs; /* start searching for table space near the * end of chk/nxt arrays */ } else i = firstfree; /* start searching for table space from the * beginning (skipping only the elements * which will definitely not hold the new * state) */ while ( 1 ) /* loops until a space is found */ { if ( i + numecs > current_max_xpairs ) expand_nxt_chk(); /* loops until space for end-of-buffer and action number are found */ while ( 1 ) { if ( chk[i - 1] == 0 ) /* check for action number space */ { if ( chk[i] == 0 ) /* check for end-of-buffer space */ break; else i += 2; /* since i != 0, there is no use checking to * see if (++i) - 1 == 0, because that's the * same as i == 0, so we skip a space */ } else ++i; if ( i + numecs > current_max_xpairs ) expand_nxt_chk(); } /* if we started search from the beginning, store the new firstfree for * the next call of find_table_space() */ if ( numtrans <= MAX_XTIONS_FOR_FULL_INTERIOR_FIT ) firstfree = i + 1; /* check to see if all elements in chk (and therefore nxt) that are * needed for the new state have not yet been taken */ state_ptr = &state[1]; ptr_to_last_entry_in_state = &chk[i + numecs + 1]; for ( chk_ptr = &chk[i + 1]; chk_ptr != ptr_to_last_entry_in_state; ++chk_ptr ) if ( *(state_ptr++) != 0 && *chk_ptr != 0 ) break; if ( chk_ptr == ptr_to_last_entry_in_state ) return ( i ); else ++i; } }/* genctbl - generates full speed compressed transition table * * synopsis * genctbl(); */genctbl() { int i; int tmp, tmp2, tmp3; /* table of verify for transition and offset to next state */ printf( "static struct yy_trans_info yy_transition[%d] =\n", tblend + numecs + 1 ); printf( " {\n" ); /* We want the transition to be represented as the offset to the * next state, not the actual state number, which is what it currently is. * The offset is base[nxt[i]] - base[chk[i]]. That's just the * difference between the starting points of the two involved states * (to - from). * * first, though, we need to find some way to put in our end-of-buffer * flags and states. We do this by making a state with absolutely no * transitions. We put it at the end of the table. */ /* at this point, we're guaranteed that there's enough room in nxt[] * and chk[] to hold tblend + numecs entries. We need just two slots. * One for the action and one for the end-of-buffer transition. We * now *assume* that we're guaranteed the only character we'll try to * index this nxt/chk pair with is EOB, i.e., 0, so we don't have to * make sure there's room for jam entries for other characters. */ base[lastdfa + 1] = tblend + 2; nxt[tblend + 1] = END_OF_BUFFER_ACTION; chk[tblend + 1] = numecs + 1; chk[tblend + 2] = 1; /* anything but EOB */ nxt[tblend + 2] = 0; /* so that "make test" won't show arb. differences */ /* make sure every state has a end-of-buffer transition and an action # */ for ( i = 0; i <= lastdfa; ++i ) { tmp = base[i]; chk[tmp] = EOB_POSITION; chk[tmp - 1] = ACTION_POSITION; nxt[tmp - 1] = dfaacc[i].dfaacc_state; /* action number */ } for ( i = 0; i <= lastsc * 2; ++i ) { tmp = base[i]; nxt[tmp - 1] = DEFAULT_ACTION; } dataline = 0; datapos = 0; for ( i = 0; i <= tblend; ++i ) { if ( chk[i] == EOB_POSITION ) transition_struct_out( 0, base[lastdfa + 1] - i ); else if ( chk[i] == ACTION_POSITION ) transition_struct_out( 0, nxt[i] ); else if ( chk[i] > numecs || chk[i] == 0 ) transition_struct_out( 0, 0 ); /* unused slot */ else /* verify, transition */ tmp = nxt[i]; tmp2 = base[tmp]; tmp3 = chk[i]; transition_struct_out( tmp3, tmp2 - (i - tmp3) ); } /* here's the final, end-of-buffer state */ transition_struct_out( chk[tblend + 1], nxt[tblend + 1] ); transition_struct_out( chk[tblend + 2], nxt[tblend + 2] ); printf( " };\n" ); printf( "\n" ); /* table of pointers to start states */ printf( "static struct yy_trans_info *yy_state_ptr[%d] =\n", lastsc * 2 + 1 ); printf( " {\n" ); for ( i = 0; i <= lastsc * 2; ++i ) printf( " &yy_transition[%d],\n", base[i] ); printf( " };\n" ); if ( useecs ) genecs(); }/* gentabs - generate data statements for the transition tables * * synopsis * gentabs(); */gentabs() { int i, j, k, *accset, nacc, *acc_array; char clower(); /* *everything* is done in terms of arrays starting at 1, so provide * a null entry for the zero element of all FTL arrays */ static char ftl_long_decl[] = "static long int %c[%d] =\n { 0,\n"; static char ftl_short_decl[] = "static short int %c[%d] =\n { 0,\n"; static char ftl_char_decl[] = "static char %c[%d] =\n { 0,\n"; acc_array = allocate_integer_array( current_max_dfas ); nummt = 0; if ( fulltbl ) jambase = lastdfa + 1; /* home of "jam" pseudo-state */ printf( "#define YY_JAM %d\n", jamstate ); printf( "#define YY_JAM_BASE %d\n", jambase ); if ( usemecs ) printf( "#define YY_TEMPLATE %d\n", lastdfa + 2 ); if ( reject ) { /* write out accepting list and pointer list * first we generate the ACCEPT array. In the process, we compute * the indices that will go into the ALIST array, and save the * indices in the dfaacc array */ printf( accnum > 127 ? ftl_short_decl : ftl_char_decl, ACCEPT, max( numas, 1 ) + 1 ); j = 1; /* index into ACCEPT array */ for ( i = 1; i <= lastdfa; ++i ) { acc_array[i] = j; if ( accsiz[i] != 0 ) { accset = dfaacc[i].dfaacc_set; nacc = accsiz[i]; if ( trace ) fprintf( stderr,
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:flex ƒ:tblcmp.c
+++++ Continued from previous card +++++
"state # %d accepts: ", i ); for ( k = 1; k <= nacc; ++k ) { ++j; mkdata( accset[k] ); if ( trace ) { fprintf( stderr, "[%d]", accset[k] ); if ( k < nacc ) fputs( ", ", stderr ); else putc( '\n', stderr ); } } } } /* add accepting number for the "jam" state */ acc_array[i] = j; dataend(); } else { for ( i = 1; i <= lastdfa; ++i ) acc_array[i] = dfaacc[i].dfaacc_state; acc_array[i] = 0; /* add (null) accepting number for jam state */ } /* spit out ALIST array. If we're doing "reject", it'll be pointers * into the ACCEPT array. Otherwise it's actual accepting numbers. * In either case, we just dump the numbers. */ /* "lastdfa + 2" is the size of ALIST; includes room for FTL arrays * beginning at 0 and for "jam" state */ k = lastdfa + 2; if ( reject ) /* we put a "cap" on the table associating lists of accepting * numbers with state numbers. This is needed because we tell * where the end of an accepting list is by looking at where * the list for the next state starts. */ ++k; printf( ((reject && numas > 126) || accnum > 127) ? ftl_short_decl : ftl_char_decl, ALIST, k ); /* set up default actions */ for ( i = 1; i <= lastsc * 2; ++i ) acc_array[i] = DEFAULT_ACTION; acc_array[end_of_buffer_state] = END_OF_BUFFER_ACTION; for ( i = 1; i <= lastdfa; ++i ) { mkdata( acc_array[i] ); if ( ! reject && trace && acc_array[i] ) fprintf( stderr, "state # %d accepts: [%d]\n", i, acc_array[i] ); } /* add entry for "jam" state */ mkdata( acc_array[i] ); if ( reject ) /* add "cap" for the list */ mkdata( acc_array[i] ); dataend(); if ( useecs ) genecs(); if ( usemecs ) { /* write out meta-equivalence classes (used to index templates with) */ if ( trace ) fputs( "\n\nMeta-Equivalence Classes:\n", stderr ); printf( ftl_char_decl, MATCHARRAY, numecs + 1 ); for ( i = 1; i <= numecs; ++i ) { if ( trace ) fprintf( stderr, "%d = %d\n", i, abs( tecbck[i] ) ); mkdata( abs( tecbck[i] ) ); } dataend(); } if ( ! fulltbl ) { int total_states = lastdfa + numtemps; printf( tblend > MAX_SHORT ? ftl_long_decl : ftl_short_decl, BASEARRAY, total_states + 1 ); for ( i = 1; i <= lastdfa; ++i ) { register int d = def[i]; if ( base[i] == JAMSTATE ) base[i] = jambase; if ( d == JAMSTATE ) def[i] = jamstate; else if ( d < 0 ) { /* template reference */ ++tmpuses; def[i] = lastdfa - d + 1; } mkdata( base[i] ); } /* generate jam state's base index */ mkdata( base[i] ); for ( ++i /* skip jam state */; i <= total_states; ++i ) { mkdata( base[i] ); def[i] = jamstate; } dataend(); printf( tblend > MAX_SHORT ? ftl_long_decl : ftl_short_decl, DEFARRAY, total_states + 1 ); for ( i = 1; i <= total_states; ++i ) mkdata( def[i] ); dataend(); printf( lastdfa > MAX_SHORT ? ftl_long_decl : ftl_short_decl, NEXTARRAY, tblend + 1 ); for ( i = 1; i <= tblend; ++i ) { if ( nxt[i] == 0 || chk[i] == 0 ) nxt[i] = jamstate; /* new state is the JAM state */ mkdata( nxt[i] ); } dataend(); printf( lastdfa > MAX_SHORT ? ftl_long_decl : ftl_short_decl, CHECKARRAY, tblend + 1 ); for ( i = 1; i <= tblend; ++i ) { if ( chk[i] == 0 ) ++nummt; mkdata( chk[i] ); } dataend(); } }/* generate equivalence-class tables */genecs() { register int i, j; static char ftl_char_decl[] = "static char %c[%d] =\n { 0,\n"; int numrows; char altchar; printf("#if EOLCHAR == %d\n",EOLCHAR); printf( ftl_char_decl, ECARRAY, CSIZE + 1 ); for ( i = 1; i <= CSIZE; ++i ) { if ( caseins && (i >= 'A') && (i <= 'Z') ) ecgroup[i] = ecgroup[clower( i )]; ecgroup[i] = abs( ecgroup[i] ); mkdata( ecgroup[i] ); } dataend(); printf("#else\n"); altchar = ecgroup[EOLCHAR];#if EOLCHAR == 10 ecgroup[10] = ecgroup[13]; ecgroup[13] = altchar;#else ecgroup[13] = ecgroup[10]; ecgroup[10] = altchar;#endif printf( ftl_char_decl, ECARRAY, CSIZE + 1 ); for ( i = 1; i <= CSIZE; ++i ) { if ( caseins && (i >= 'A') && (i <= 'Z') ) ecgroup[i] = ecgroup[clower( i )]; ecgroup[i] = abs( ecgroup[i] ); mkdata( ecgroup[i] ); } dataend(); printf("#endif\n"); if ( trace ) { fputs( "\n\nEquivalence Classes:\n\n", stderr ); numrows = (CSIZE + 1) / 8; for ( j = 1; j <= numrows; ++j ) { for ( i = j; i <= CSIZE; i = i + numrows ) { if ( i >= 1 && i <= 31 ) fprintf( stderr, "^%c = %-2d", 'A' + i - 1, ecgroup[i] ); else if ( i >= 32 && i <= 126 ) fprintf( stderr, " %c = %-2d", i, ecgroup[i] ); else if ( i == 127 ) fprintf( stderr, "^@ = %-2d", ecgroup[i] ); else fprintf( stderr, "\nSomething Weird: %d = %d\n", i, ecgroup[i] ); putc( '\t', stderr ); } putc( '\n', stderr ); } } }/* inittbl - initialize transition tables * * synopsis * inittbl(); * * Initializes "firstfree" to be one beyond the end of the table. Initializes * all "chk" entries to be zero. Note that templates are built in their * own tbase/tdef tables. They are shifted down to be contiguous * with the non-template entries during table generation. */inittbl() { register int i; bzero( (char *) chk, current_max_xpairs * sizeof( int ) / sizeof( char ) ); tblend = 0; firstfree = tblend + 1; numtemps = 0; if ( usemecs ) { /* set up doubly-linked meta-equivalence classes * these are sets of equivalence classes which all have identical * transitions out of TEMPLATES */ tecbck[1] = NIL; for ( i = 2; i <= numecs; ++i ) { tecbck[i] = i - 1; tecfwd[i - 1] = i; } tecfwd[numecs] = NIL; } }/* make_tables - generate transition tables * * synopsis * make_tables(); * * Generates transition tables and finishes generating output file */make_tables() { if ( fullspd ) { /* need to define YY_TRANS_OFFSET_TYPE as a size large * enough to hold the biggest offset */ int total_table_size = tblend + numecs + 1; printf( "#define YY_TRANS_OFFSET_TYPE %s\n", total_table_size > MAX_SHORT ? "long" : "short" ); } if ( fullspd || fulltbl ) skelout(); /* compute the tables and copy them to output file */ if ( fullspd ) genctbl(); else gentabs(); skelout(); (void) fclose( temp_action_file ); temp_action_file = fopen( action_file_name, "r" ); /* copy prolog from action_file to output file */ action_out(); skelout(); /* copy actions from action_file to output file */ action_out(); skelout(); /* copy remainder of input to output */ line_directive_out( stdout ); (void) flexscan(); /* copy remainder of input to output */ }/* mkdeftbl - make the default, "jam" table entries * * synopsis * mkdeftbl(); */mkdeftbl() { int i; jamstate = lastdfa + 1; if ( tblend + numecs > current_max_xpairs ) expand_nxt_chk(); for ( i = 1; i <= numecs; ++i ) { nxt[tblend + i] = 0; chk[tblend + i] = jamstate; } jambase = tblend; base[jamstate] = jambase; /* should generate a run-time array bounds check if * ever used as a default */ def[jamstate] = BAD_SUBSCRIPT; tblend += numecs; ++numtemps; }/* mkentry - create base/def and nxt/chk entries for transition array * * synopsis * int state[numchars + 1], numchars, statenum, deflink, totaltrans; * mkentry( state, numchars, statenum, deflink, totaltrans ); * * "state" is a transition array "numchars" characters in size, "statenum" * is the offset to be used into the base/def tables, and "deflink" is the * entry to put in the "def" table entry. If "deflink" is equal to * "JAMSTATE", then no attempt will be made to fit zero entries of "state" * (i.e., jam entries) into the table. It is assumed that by linking to * "JAMSTATE" they will be taken care of. In any case, entries in "state" * marking transitions to "SAME_TRANS" are treated as though they will be * taken care of by whereever "deflink" points. "totaltrans" is the total * number of transitions out of the state. If it is below a certain threshold, * the tables are searched for an interior spot that will accommodate the * state array. */mkentry( state, numchars, statenum, deflink, totaltrans )register int *state;int numchars, statenum, deflink, totaltrans; { register int minec, maxec, i, baseaddr; int tblbase, tbllast; if ( totaltrans == 0 ) { /* there are no out-transitions */ if ( deflink == JAMSTATE ) base[statenum] = JAMSTATE; else base[statenum] = 0; def[statenum] = deflink; return; } for ( minec = 1; minec <= numchars; ++minec ) { if ( state[minec] != SAME_TRANS ) if ( state[minec] != 0 || deflink != JAMSTATE ) break; } if ( totaltrans == 1 ) { /* there's only one out-transition. Save it for later to fill * in holes in the tables. */ stack1( statenum, minec, state[minec], deflink ); return; } for ( maxec = numchars; maxec > 0; --maxec ) { if ( state[maxec] != SAME_TRANS ) if ( state[maxec] != 0 || deflink != JAMSTATE ) break; } /* Whether we try to fit the state table in the middle of the table * entries we have already generated, or if we just take the state * table at the end of the nxt/chk tables, we must make sure that we * have a valid base address (i.e., non-negative). Note that not only are * negative base addresses dangerous at run-time (because indexing the * next array with one and a low-valued character might generate an * array-out-of-bounds error message), but at compile-time negative * base addresses denote TEMPLATES. */ /* find the first transition of state that we need to worry about. */ if ( totaltrans * 100 <= numchars * INTERIOR_FIT_PERCENTAGE ) { /* attempt to squeeze it into the middle of the tabls */ baseaddr = firstfree; while ( baseaddr < minec ) { /* using baseaddr would result in a negative base address below * find the next free slot */ for ( ++baseaddr; chk[baseaddr] != 0; ++baseaddr ) ; } if ( baseaddr + maxec - minec >= current_max_xpairs ) expand_nxt_chk(); for ( i = minec; i <= maxec; ++i ) if ( state[i] != SAME_TRANS ) if ( state[i] != 0 || deflink != JAMSTATE ) if ( chk[baseaddr + i - minec] != 0 ) { /* baseaddr unsuitable - find another */ for ( ++baseaddr; baseaddr < current_max_xpairs && chk[baseaddr] != 0; ++baseaddr ) ; if ( baseaddr + maxec - minec >= current_max_xpairs ) expand_nxt_chk(); /* reset the loop counter so we'll start all * over again next time it's incremented */ i = minec - 1; } } else { /* ensure that the base address we eventually generate is * non-negative */ baseaddr = max( tblend + 1, minec ); } tblbase = baseaddr - minec; tbllast = tblbase + maxec; if ( tbllast >= current_max_xpairs ) expand_nxt_chk(); base[statenum] = tblbase; def[statenum] = deflink; for ( i = minec; i <= maxec; ++i ) if ( state[i] != SAME_TRANS ) if ( state[i] != 0 || deflink != JAMSTATE ) { nxt[tblbase + i] = state[i]; chk[tblbase + i] = statenum; } if ( baseaddr == firstfree ) /* find next free slot in tables */ for ( ++firstfree; chk[firstfree] != 0; ++firstfree ) ; tblend = max( tblend, tbllast ); }/* mk1tbl - create table entries for a state (or state fragment) which * has only one out-transition * * synopsis * int state, sym, onenxt, onedef; * mk1tbl( state, sym, onenxt, onedef ); */mk1tbl( state, sym, onenxt, onedef )int state, sym, onenxt, onedef; { if ( firstfree < sym ) firstfree = sym; while ( chk[firstfree] != 0 ) if ( ++firstfree >= current_max_xpairs ) expand_nxt_chk(); base[state] = firstfree - sym; def[state] = onedef; chk[firstfree] = state; nxt[firstfree] = onenxt; if ( firstfree > tblend ) { tblend = firstfree++; if ( firstfree >= current_max_xpairs ) expand_nxt_chk(); } }/* mkprot - create new proto entry * * synopsis * int state[], statenum, comstate; * mkprot( state, statenum, comstate ); */mkprot( state, statenum, comstate )int state[], statenum, comstate; { int i, slot, tblbase; if ( ++numprots >= MSP || numecs * numprots >= PROT_SAVE_SIZE ) { /* gotta make room for the new proto by dropping last entry in * the queue */ slot = lastprot; lastprot = protprev[lastprot]; protnext[lastprot] = NIL; } else slot = numprots; protnext[slot] = firstprot; if ( firstprot != NIL ) protprev[firstprot] = slot; firstprot = slot; prottbl[slot] = statenum; protcomst[slot] = comstate; /* copy state into save area so it can be compared with rapidly */ tblbase = numecs * (slot - 1); for ( i = 1; i <= numecs; ++i ) protsave[tblbase + i] = state[i]; }/* mktemplate - create a template entry based on a state, and connect the state * to it * * synopsis * int state[], statenum, comstate, totaltrans; * mktemplate( state, statenum, comstate, totaltrans ); */mktemplate( state, statenum, comstate )int state[], statenum, comstate; { int i, numdiff, tmpbase, tmp[CSIZE + 1]; char transset[CSIZE + 1]; int tsptr; ++numtemps; tsptr = 0; /* calculate where we will temporarily store the transition table * of the template in the tnxt[] array. The final transition table * gets created by cmptmps() */ tmpbase = numtemps * numecs; if ( tmpbase + numecs >= current_max_template_xpairs ) { current_max_template_xpairs += MAX_TEMPLATE_XPAIRS_INCREMENT; ++num_reallocs; tnxt = reallocate_integer_array( tnxt, current_max_template_xpairs ); } for ( i = 1; i <= numecs; ++i ) if ( state[i] == 0 ) tnxt[tmpbase + i] = 0; else { transset[tsptr++] = i; tnxt[tmpbase + i] = comstate; } if ( usemecs ) mkeccl( transset, tsptr, tecfwd, tecbck, numecs ); mkprot( tnxt + tmpbase, -numtemps, comstate ); /* we rely on the fact that mkprot adds things to the beginning * of the proto queue */ numdiff = tbldiff( state, firstprot, tmp ); mkentry( tmp, numecs, statenum, -numtemps, numdiff ); }/* mv2front - move proto queue element to front of queue * * synopsis * int qelm; * mv2front( qelm ); */mv2front( qelm )int qelm; { if ( firstprot != qelm ) { if ( qelm == lastprot ) lastprot = protprev[lastprot]; protnext[protprev[qelm]] = protnext[qelm]; if ( protnext[qelm] != NIL ) protprev[protnext[qelm]] = protprev[qelm]; protprev[qelm] = NIL; protnext[qelm] = firstprot; protprev[firstprot] = qelm; firstprot = qelm; } }/* ntod - convert an ndfa to a dfa * * synopsis * ntod(); * * creates the dfa corresponding to the ndfa we've constructed. the * dfa starts out in state #1. */ntod() { int *accset, ds, nacc, newds; int duplist[CSIZE + 1], sym, hashval, numstates, dsize; int targfreq[CSIZE + 1], targstate[CSIZE + 1], state[CSIZE + 1]; int *nset, *dset; int targptr, totaltrans, i, comstate, comfreq, targ; int *epsclosure(), snstods(), symlist[CSIZE + 1]; /* this is so find_table_space(...) will know where to start looking in * chk/nxt for unused records for space to put in the state */ if ( fullspd ) firstfree = 0; accset = allocate_integer_array( accnum + 1 ); nset = allocate_integer_array( current_max_dfa_size );
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:flex ƒ:tblcmp.c
+++++ Continued from previous card +++++
todo_head = todo_next = 0;#define ADD_QUEUE_ELEMENT(element) \ if ( ++element >= current_max_dfas ) \ { /* check for queue overflowing */ \ if ( todo_head == 0 ) \ increase_max_dfas(); \ else \ element = 0; \ }#define NEXT_QUEUE_ELEMENT(element) ((element + 1) % (current_max_dfas + 1)) for ( i = 0; i <= CSIZE; ++i ) { duplist[i] = NIL; symlist[i] = false; } for ( i = 0; i <= accnum; ++i ) accset[i] = NIL; if ( trace ) { dumpnfa( scset[1] ); fputs( "\n\nDFA Dump:\n\n", stderr ); } inittbl(); if ( fullspd ) { for ( i = 0; i <= numecs; ++i ) state[i] = 0; place_state( state, 0, 0 ); } if ( fulltbl ) { /* declare it "short" because it's a real long-shot that that * won't be large enough */ printf( "static short int %c[][%d] =\n {\n", NEXTARRAY, numecs + 1 ); /* '}' so vi doesn't get too confused */ /* generate 0 entries for state #0 */ for ( i = 0; i <= numecs; ++i ) mk2data( 0 ); /* force ',' and dataflush() next call to mk2data */ datapos = NUMDATAITEMS; /* force extra blank line next dataflush() */ dataline = NUMDATALINES; } /* create the first states */ for ( i = 1; i <= lastsc * 2; ++i ) { numstates = 1; /* for each start condition, make one state for the case when * we're at the beginning of the line (the '%' operator) and * one for the case when we're not */ if ( i % 2 == 1 ) nset[numstates] = scset[(i / 2) + 1]; else nset[numstates] = mkbranch( scbol[i / 2], scset[i / 2] ); nset = epsclosure( nset,tes, accset, &nacc, &hashval ); if ( snstods( nset, numstates, accset, nacc, hashval, &ds ) ) { numas = numas + nacc; totnst = totnst + numstates; todo[todo_next] = ds; ADD_QUEUE_ELEMENT(todo_next); } } if ( fulltbl ) { if ( ! snstods( nset, 0, accset, 0, 0, &end_of_buffer_state ) ) flexfatal( "could not create unique end-of-buffer state" ); numas += 1; todo[todo_next] = end_of_buffer_state; ADD_QUEUE_ELEMENT(todo_next); } while ( todo_head != todo_next ) { targptr = 0; totaltrans = 0; for ( i = 1; i <= numecs; ++i ) state[i] = 0; ds = todo[todo_head]; todo_head = NEXT_QUEUE_ELEMENT(todo_head); dset = dss[ds]; dsize = dfasiz[ds]; if ( trace ) fprintf( stderr, "state # %d:\n", ds ); sympartition( dset, dsize, symlist, duplist ); for ( sym = 1; sym <= numecs; ++sym ) { if ( symlist[sym] ) { symlist[sym] = 0; if ( duplist[sym] == NIL ) { /* symbol has unique out-transitions */ numstates = symfollowset( dset, dsize, sym, nset ); nset = epsclosure( nset, &numstates, accset, &nacc, &hashval ); if ( snstods( nset, numstates, accset, nacc, hashval, &newds ) ) { totnst = totnst + numstates; todo[todo_next] = newds; ADD_QUEUE_ELEMENT(todo_next); numas = numas + nacc; } state[sym] = newds; if ( trace ) fprintf( stderr, "\t%d\t%d\n", sym, newds ); targfreq[++targptr] = 1; targstate[targptr] = newds; ++numuniq; } else { /* sym's equivalence class has the same transitions * as duplist(sym)'s equivalence class */ targ = state[duplist[sym]]; state[sym] = targ; if ( trace ) fprintf( stderr, "\t%d\t%d\n", sym, targ ); /* update frequency count for destination state */ i = 0; while ( targstate[++i] != targ ) ; ++targfreq[i]; ++numdup; } ++totaltrans; duplist[sym] = NIL; } } numsnpairs = numsnpairs + totaltrans; if ( caseins && ! useecs ) { register int j; for ( i = 'A', j = 'a'; i <= 'Z'; ++i, ++j ) state[i] = state[j]; } if ( fulltbl ) { /* supply array's 0-element */ if ( ds == end_of_buffer_state ) mk2data( 0 ); else mk2data( end_of_buffer_state ); for ( i = 1; i <= numecs; ++i ) mk2data( state[i] ); /* force ',' and dataflush() next call to mk2data */ datapos = NUMDATAITEMS; /* force extra blank line next dataflush() */ dataline = NUMDATALINES; } else if ( fullspd ) place_state( state, ds, totaltrans ); else { /* determine which destination state is the most common, and * how many transitions to it there are */ comfreq = 0; comstate = 0; for ( i = 1; i <= targptr; ++i ) if ( targfreq[i] > comfreq ) { comfreq = targfreq[i]; comstate = targstate[i]; } bldtbl( state, ds, totaltrans, comstate, comfreq ); } } if ( fulltbl ) dataend(); else { cmptmps(); /* create compressed template entries */ /* create tables for all the states with only one out-transition */ while ( onesp > 0 ) { mk1tbl( onestate[onesp], onesym[onesp], onenext[onesp], onedef[onesp] ); --onesp; } mkdeftbl(); } }/* place_state - place a state into full speed transition table * * synopsis * int *state, statenum, transnum; * place_state( state, statenum, transnum ); * * State is the statenum'th state. It is indexed by equivalence class and * gives the number of the state to enter for a given equivalence class. * Transnum is the number of out-transitions for the state. */place_state( state, statenum, transnum )int *state, statenum, transnum; { register int i; register int *state_ptr; int position = find_table_space( state, transnum ); /* base is the table of start positions */ base[statenum] = position; /* put in action number marker; this non-zero number makes sure that * find_table_space() knows that this position in chk/nxt is taken * and should not be used for another accepting number in another state */ chk[position - 1] = 1; /* put in end-of-buffer marker; this is for the same purposes as above */ chk[position] = 1; /* place the state into chk and nxt */ state_ptr = &state[1]; for ( i = 1; i <= numecs; ++i, ++state_ptr ) if ( *state_ptr != 0 ) { chk[position + i] = i; nxt[position + i] = *state_ptr; } if ( position + numecs > tblend ) tblend = position + numecs; }/* stack1 - save states with only one out-transition to be processed later * * synopsis * int statenum, sym, nextstate, deflink; * stack1( statenum, sym, nextstate, deflink ); * * if there's room for another state one the "one-transition" stack, the * state is pushed onto it, to be processed later by mk1tbl. If there's * no room, we process the sucker right now. */stack1( statenum, sym, nextstate, deflink )int statenum, sym, nextstate, deflink; { if ( onesp >= ONE_STACK_SIZE ) mk1tbl( statenum, sym, nextstate, deflink ); else { ++onesp; onestate[onesp] = statenum; onesym[onesp] = sym; onenext[onesp] = nextstate; onedef[onesp] = deflink; } }/* tbldiff - compute differences between two state tables * * synopsis * int state[], pr, ext[]; * int tbldiff, numdifferences; * numdifferences = tbldiff( state, pr, ext ) * * "state" is the state array which is to be extracted from the pr'th * proto. "pr" is both the number of the proto we are extracting from * and an index into the save area where we can find the proto's complete * state table. Each entry in "state" which differs from the corresponding * entry of "pr" will appear in "ext". * Entries which are the same in both "state" and "pr" will be marked * as transitions to "SAME_TRANS" in "ext". The total number of differences * between "state" and "pr" is returned as function value. Note that this * number is "numecs" minus the number of "SAME_TRANS" entries in "ext". */int tbldiff( state, pr, ext )int state[], pr, ext[]; { register int i, *sp = state, *ep = ext, *protp; register int numdiff = 0; protp = &protsave[numecs * (pr - 1)]; for ( i = numecs; i > 0; --i ) { if ( *++protp == *++sp ) *++ep = SAME_TRANS; else { *++ep = *sp; ++numdiff; } } return ( numdiff ); } :MPW:MPW Tools:Tools with Source:flex ƒ:Timings
flex vs. lex timings for a C tokenizer which includes keywords:Generation times: lex 83.0 secs flex 3.9 flex -cfe 7.1 # uncompressed table, equivalence classes flex -cf 15.0 # uncompressed table, no equivalence classesScanner object file sizes: lex 41.0K bytes flex 9.4K flex -cfe 49.6K flex -cf 126.5KRunning times on a 28,088 line input (685K characters): lex 29.8 secs flex 19.3 flex -cfe 9.0 flex -cf 7.8The timings were made on a Sun 3/60. All times are user + system CPU time,and don't include hashing of identifiers.Summary: For about the same sized scanner, you get a factor of 3 in performance. For a 30% faster scanner, you get a scanner 1/4th the size, and it's generated in 1/20th the time. For a scanner that's 3 times larger, you get a factor of 3.8 in performance. :MPW:MPW Tools:Tools with Source:flex ƒ:yylex.c
/* yylex - scanner front-end for flex */#include "flexdef.h"#include "parse.h"/* * Copyright (c) 1987, the University of California * * The United States Government has rights in this work pursuant to * contract no. DE-AC03-76SF00098 between the United States Department of * Energy and the University of California. * * This program may be redistributed. Enhancements and derivative works * may be created provided the new works, if made available to the general * public, are made available for use by anyone. *//* yylex - scan for a regular expression token * * synopsis * * token = yylex(); * * token - return token found */int yylex() { int toktype; static int beglin = false; if ( eofseen ) toktype = EOF; else toktype = flexscan(); if ( toktype == EOF ) { eofseen = 1; if ( sectnum == 1 ) { synerr( "unexpected EOF" ); sectnum = 2; toktype = SECTEND; } else if ( sectnum == 2 ) { sectnum = 3; toktype = SECTEND; } else toktype = 0; } if ( trace ) { if ( beglin ) { fprintf( stderr, "%d\t", accnum + 1 ); beglin = 0; } switch ( toktype ) { case '<': case '>': case '^': case '$': case '"': case '[': case ']': case '{': case '}': case '|': case '(': case ')': case '-': case '/': case '\\': case '?': case '.': case '*': case '+': case ',': (void) putc( toktype, stderr ); break; case EOLCHAR: (void) putc( '\n', stderr ); if ( sectnum == 2 ) beglin = 1; break; case SCDECL: fputs( "%s", stderr ); break; case XSCDECL: fputs( "%x", stderr ); break; case WHITESPACE: (void) putc( ' ', stderr ); break; case SECTEND: fputs( "%%\n", stderr ); /* we set beglin to be true so we'll start * writing out numbers as we echo rules. flexscan() has * already assigned sectnum */ if ( sectnum == 2 ) beglin = 1; break; case NAME: fprintf( stderr, "'%s'", nmstr ); break; case CHAR: switch ( yylval ) { case '<': case '>': case '^': case '$': case '"': case '[': case ']': case '{': case '}': case '|': case '(': case ')': case '-': case '/': case '\\': case '?': case '.': case '*': case '+': case ',': fprintf( stderr, "\\%c", yylval ); break; case 1: case 2: case 3: case 4: case 5: case 6: case 7: case 8: case 9: case 10: case 11: case 12: case 13: case 14: case 15: case 16: case 17: case 18: case 19: case 20: case 21: case 22: case 23: case 24: case 25: case 26: case 27: case 28: case 29: case 30: case 31: fprintf( stderr, "^%c", 'A' + yylval - 1 ); break; case 127: (void) putc( '^', stderr ); (void) putc( '@', stderr ); break; default: (void) putc( yylval, stderr ); break; } break; case NUMBER: fprintf( stderr, "%d", yylval ); break; case PREVCCL: fprintf( stderr, "[%d]", yylval ); break; case 0: fprintf( stderr, "End Marker" ); break; default: fprintf( stderr, "*Something Weird* - tok: %d val: %d\n", toktype, yylval ); break; } } return ( toktype ); } :MPW:MPW Tools:Tools with Source:FLPATH.TXT
{ An MPW Pascal Tool Demo - John Jeppson File Path and Directory Information: what to save, how to extract it, and how to reconstruct it.} PROGRAM test;USES Memtypes, Quickdraw, OSIntf, ToolIntf, PackIntf, CursorCtl, Signal, PasLibIntf, IntEnv;VAR { Info to save - could be made into a record } volumeName: Str31; fileName: Str31; directoryID: longint; reply: SFReply; { used by this demo }FUNCTION reconstructWD: integer; VAR pb: WDPBRec; err: OSErr; s: string; BEGIN s := ':'; Insert(volumeName, s, 1); {get volume refnum} pb.ioCompletion := NIL; pb.ioNamePtr := @s; pb.ioVRefNum := 0; pb.ioWDProcID := 0; pb.ioWDDirID := 0; err := PBOpenWD(@pb, false); {get WDRefnum} pb.ioCompletion := NIL; pb.ioNamePtr := NIL; {pb.ioVRefNum from above} pb.ioWDProcID := 0; pb.ioWDDirID := directoryID; err := PBOpenWD(@pb, false); reconstructWD := pb.ioVRefNum; END;PROCEDURE extractFilePath; VAR pb: WDPBRec; err: OSErr; BEGIN pb.ioCompletion := NIL; pb.ioNamePtr := @volumeName; pb.ioVRefNum := reply.vRefNum; pb.ioWDIndex := 0; pb.ioWDProcID := 0; pb.ioWDVRefNum := 0; err := PBGetWDInfo(@pb, false); directoryID := pb.ioWDDirID; END;PROCEDURE getReply; VAR where: Point; typelist: SFTypeList; BEGIN where.h := 75; where.v := 75; SFGetFile(where, '', NIL, - 1, typelist, NIL, reply); IF reply.good THEN fileName := reply.fName ELSE IEExit(2); END;BEGIN InitGraf(@thePort); SetFScaleDisable(true); getReply; writeln(fileName, reply.vRefNum); extractFilePath; writeln(volumeName, directoryID); writeln('restored WD = ', reconstructWD);END. :MPW:MPW Tools:Tools with Source:gawk:gawk-2.11:alloca.c
/* alloca -- (mostly) portable public-domain implementation -- D A Gwyn last edit: 86/05/30 rms include config.h, since on VMS it renames some symbols. Use xmalloc instead of malloc. This implementation of the PWB library alloca() function, which is used to allocate space off the run-time stack so that it is automatically reclaimed upon procedure exit, was inspired by discussions with J. Q. Johnson of Cornell. It should work under any C implementation that uses an actual procedure stack (as opposed to a linked list of frames). There are some preprocessor constants that can be defined when compiling for your specific system, for improved efficiency; however, the defaults should be okay. The general concept of this implementation is to keep track of all alloca()-allocated blocks, and reclaim any that are found to be deeper in the stack than the current invocation. This heuristic does not reclaim storage as soon as it becomes invalid, but it will do so eventually. As a special case, alloca(0) reclaims storage without allocating any. It is a good idea to use alloca(0) in your main control loop, etc. to force garbage collection.*/#ifndef lintstatic char SCCSid[] = "@(#)alloca.c 1.1"; /* for the "what" utility */#endif#ifdef THINK_C#include <stdio.h>#include <stdlib.h>#include <string.h>#include "config.h"#endif /* THINK_C */#ifdef emacs#if defined(static) /* THINK_C barfs on "#ifdef static" *//* actually, only want this if static is defined as "" -- this is for usg, in which emacs must undefine static in order to make unexec workable */#ifndef STACK_DIRECTIONyoulose-- must know STACK_DIRECTION at compile-time#endif /* STACK_DIRECTION undefined */#endif /* static */ /* THINK_C barfs on "#endif static" */#endif emacs#ifdef X3J11typedef void *pointer; /* generic pointer type */#elsetypedef char *pointer; /* generic pointer type */#endif#ifndef NULL#define NULL 0 /* null pointer constant */#endif/* Protoypes grabbed from file** "alloca.c"** 1990 Sep 5 (Wed) 20:40:48*/void find_stack_direction(void); pointer alloca(unsigned size); /* # bytes to allocate */pointer xmalloc(unsigned int n); extern void free();/* Define STACK_DIRECTION if you know the direction of stack growth for your system; otherwise it will be automatically deduced at run-time. STACK_DIRECTION > 0 => grows toward higher addresses STACK_DIRECTION < 0 => grows toward lower addresses STACK_DIRECTION = 0 => direction of growth unknown*/#ifndef STACK_DIRECTION#define STACK_DIRECTION 0 /* direction unknown */#endif#if STACK_DIRECTION != 0#define STACK_DIR STACK_DIRECTION /* known at compile-time */#else /* STACK_DIRECTION == 0; need run-time code */static int stack_dir; /* 1 or -1 once known */#define STACK_DIR stack_dirstatic voidfind_stack_direction (/* void */){ static char *addr = NULL; /* address of first `dummy', once known */ auto char dummy; /* to get stack address */ if (addr == NULL) { /* initial entry */ addr = &dummy; find_stack_direction (); /* recurse once */ } else /* second entry */ if (&dummy > addr) stack_dir = 1; /* stack grew upward */ else stack_dir = -1; /* stack grew downward */}#endif /* STACK_DIRECTION == 0 *//* An "alloca header" is used to: (a) chain together all alloca()ed blocks; (b) keep track of stack depth. It is very important that sizeof(header) agree with malloc() alignment chunk size. The following default should work okay.*/#ifndef ALIGN_SIZE#define ALIGN_SIZE sizeof(double)#endiftypedef union hdr{ char align[ALIGN_SIZE]; /* to force sizeof(header) */ struct { union hdr *next; /* for chaining headers */ char *deep; /* for stack depth measure */ } h;} header;/* alloca( size ) returns a pointer to at least `size' bytes of storage which will be automatically reclaimed upon exit from the procedure that called alloca(). Originally, this space was supposed to be taken from the current stack frame of the caller, but that method cannot be made to work for some implementations of C, for example under Gould's UTX/32.*/static header *last_alloca_header = NULL; /* -> last alloca header */pointeralloca (size) /* returns pointer to storage */ unsigned size; /* # bytes to allocate */{ auto char probe; /* probes stack depth: */ register char *depth = &probe;#if STACK_DIRECTION == 0 if (STACK_DIR == 0) /* unknown growth direction */ find_stack_direction ();#endif /* Reclaim garbage, defined as all alloca()ed storage that was allocated from deeper in the stack than currently. */ { register header *hp; /* traverses linked list */ for (hp = last_alloca_header; hp != NULL;) if (STACK_DIR > 0 && hp->h.deep > depth || STACK_DIR < 0 && hp->h.deep < depth) { register header *np = hp->h.next; free ((pointer) hp); /* collect garbage */ hp = np; /* -> next header */ } else break; /* rest are not deeper */ last_alloca_header = hp; /* -> last valid storage */ } if (size == 0) return NULL; /* no allocation required */ /* Allocate combined header + user data storage. */ { register pointer new = xmalloc (sizeof (header) + size); /* address of header */ ((header *)new)->h.next = last_alloca_header; ((header *)new)->h.deep = depth; last_alloca_header = (header *)new; /* User storage begins just after header. */ return (pointer)((char *)new + sizeof(header)); }} :MPW:MPW Tools:Tools with Source:gawk:gawk-2.11:alloca.s
/* `alloca' standard 4.2 subroutine for 68000's and 16000's and others. Also has _setjmp and _longjmp for pyramids. Copyright (C) 1985, 1986, 1988 Free Software Foundation, Inc.This file is part of GNU Emacs.GNU Emacs is distributed in the hope that it will be useful,but WITHOUT ANY WARRANTY. No author or distributoraccepts responsibility to anyone for the consequences of using itor for whether it serves any particular purpose or works at all,unless he says so in writing. Refer to the GNU Emacs General PublicLicense for full details.Everyone is granted permission to copy, modify and redistributeGNU Emacs, but only under the conditions described in theGNU Emacs General Public License. A copy of this license issupposed to have been given to you along with GNU Emacs so youcan know your rights and responsibilities. It should be in afile named COPYING. Among other things, the copyright noticeand this notice must be preserved on all copies. *//* Both 68000 systems I have run this on have had broken versions of alloca. Also, I am told that non-berkeley systems do not have it at all. So replace whatever system-provided alloca there may be on all 68000 systems. *//* #include "config.h" */#ifndef HAVE_ALLOCA /* define this to use system's alloca */#ifndef hp9000s300#ifndef mc68k#ifndef m68000#ifndef WICAT#ifndef ns16000#ifndef sequent#ifndef pyr#ifndef ATT3B5#ifndef XENIXyoulose!!#endif /* XENIX */#endif /* ATT3B5 */#endif /* pyr */#endif /* sequent */#endif /* ns16000 */#endif /* WICAT */#endif /* m68000 */#endif /* mc68k */#endif /* hp9000s300 */#ifdef hp9000s300#ifdef OLD_HP_ASSEMBLER data text globl _alloca_alloca move.l (sp)+,a0 ; pop return addr from top of stack move.l (sp)+,d0 ; pop size in bytes from top of stack add.l #ROUND,d0 ; round size up to long word and.l #MASK,d0 ; mask out lower two bits of size sub.l d0,sp ; allocate by moving stack pointer tst.b PROBE(sp) ; stack probe to allocate pages move.l sp,d0 ; return pointer add.l #-4,sp ; new top of stack jmp (a0) ; not a normal returnMASK equ -4 ; Longword alignmentROUND equ 3 ; dittoPROBE equ -128 ; safety buffer for C compiler scratch data#else /* new hp assembler syntax *//* The new compiler does "move.m <registers> (%sp)" to save registers, so we must copy the saved registers when we mung the sp. The old compiler did "move.m <register> <offset>(%a6)", which gave us no trouble */ text set PROBE,-128 # safety for C frame temporaries set MAXREG,10 # d2-d7, a2-a5 may have been saved global _alloca_alloca: mov.l (%sp)+,%a0 # return addess mov.l (%sp)+,%d0 # number of bytes to allocate mov.l %sp,%a1 # save old sp for register copy mov.l %sp,%d1 # compute new sp sub.l %d0,%d1 # space requested and.l &-4,%d1 # round down to longword sub.l &MAXREG*4,%d1 # space for saving registers mov.l %d1,%sp # save new value of sp tst.b PROBE(%sp) # create pages (sigh) move.w &MAXREG-1,%d0copy_regs_loop: /* save caller's saved registers */ mov.l (%a1)+,(%sp)+ dbra %d0,copy_regs_loop mov.l %sp,%d0 # return value mov.l %d1,%sp add.l &-4,%sp # adjust tos jmp (%a0) # rts#endif /* new hp assembler */#else#ifdef mc68k /* SGS assembler totally different */ file "alloca.s" global allocaalloca: mov.l (%sp)+,%a1 # pop return addr from top of stack mov.l (%sp)+,%d0 # pop size in bytes from top of stack add.l &R%1,%d0 # round size up to long word and.l &-4,%d0 # mask out lower two bits of size sub.l %d0,%sp # allocate by moving stack pointer tst.b P%1(%sp) # stack probe to allocate pages mov.l %sp,%a0 # return pointer as pointer mov.l %sp,%d0 # return pointer as int to avoid disaster add.l &-4,%sp # new top of stack jmp (%a1) # not a normal return set S%1,64 # safety factor for C compiler scratch set R%1,3+S%1 # add to size for rounding set P%1,-132 # probe this far below current top of stack#else /* not mc68k */#ifdef m68000#ifdef WICAT/* * Registers are saved after the corresponding link so we have to explicitly * move them to the top of the stack where they are expected to be. * Since we do not know how many registers were saved in the calling function * we must assume the maximum possible (d2-d7,a2-a5). Hence, we end up * wasting some space on the stack. * * The large probe (tst.b) attempts to make up for the fact that we have * potentially used up the space that the caller probed for its own needs. */ .procss m0 .config "68000 1" .module _allocaMAXREG: .const 10 .sect text .global _alloca_alloca: move.l (sp)+,a1 ; pop return address move.l (sp)+,d0 ; pop allocation size move.l sp,d1 ; get current SP value sub.l d0,d1 ; adjust to reflect required size... sub.l #MAXREG*4,d1 ; ...and space needed for registers and.l #-4,d1 ; backup to longword boundry move.l sp,a0 ; save old SP value for register copy move.l d1,sp ; set the new SP value tst.b -4096(sp) ; grab an extra page (to cover caller) move.l a2,d1 ; save callers register move.l sp,a2 move.w #MAXREG-1,d0 ; # of longwords to copyloop: move.l (a0)+,(a2)+ ; copy registers... dbra d0,loop ; ...til there are no more move.l a2,d0 ; end of register area is addr for new space move.l d1,a2 ; restore saved a2. addq.l #4,sp ; caller will increment sp by 4 after return. move.l d0,a0 ; return value in both a0 and d0. jmp (a1) .end _alloca#else/* Some systems want the _, some do not. Win with both kinds. */.globl _alloca_alloca:.globl allocaalloca: movl sp@+,a0 movl a7,d0 subl sp@,d0 andl #~3,d0 movl d0,sp tstb sp@(0) /* Make stack pages exist */ /* Needed on certain systems that lack true demand paging */ addql #4,d0 jmp a0@#endif /* not WICAT */#endif /* m68000 */#endif /* not mc68k */#endif /* not hp9000s300 */#ifdef ns16000 .text .align 2/* Some systems want the _, some do not. Win with both kinds. */.globl _alloca_alloca:.globl allocaalloca:/* Two different assembler syntaxes are used for the same code on different systems. */#ifdef sequent#define IM#define REGISTER(x) x#else#define IM $#define REGISTER(x) 0(x)#endif/* * The ns16000 is a little more difficult, need to copy regs. * Also the code assumes direct linkage call sequence (no mod table crap). * We have to copy registers, and therefore waste 32 bytes. * * Stack layout: * new sp -> junk * registers (copy) * r0 -> new data * | (orig retval) * | (orig arg) * old sp -> regs (orig) * local data * fp -> old fp */ movd tos,r1 /* pop return addr */ negd tos,r0 /* pop amount to allocate */ sprd sp,r2 addd r2,r0 bicb IM/**/3,r0 /* 4-byte align */ lprd sp,r0 adjspb IM/**/36 /* space for regs, +4 for caller to pop */ movmd 0(r2),4(sp),IM/**/4 /* copy regs */ movmd 0x10(r2),0x14(sp),IM/**/4 jump REGISTER(r1) /* funky return */#endif /* ns16000 */#ifdef pyr.globl _alloca_alloca: addw $3,pr0 # add 3 (dec) to first argument bicw $3,pr0 # then clear its last 2 bits subw pr0,sp # subtract from SP the val in PR0 andw $-32,sp # keep sp aligned on multiple of 32. movw sp,pr0 # ret. current SP ret#ifdef PYRAMID_OLD /* This isn't needed in system version 4. */.globl __longjmp.globl _longjmp.globl __setjmp.globl _setjmp__longjmp: jump _longjmp__setjmp: jump _setjmp#endif#endif /* pyr */#ifdef ATT3B5 .align 4 .globl allocaalloca: movw %ap, %r8 subw2 $9*4, %r8 movw 0(%r8), %r1 /* pc */ movw 4(%r8), %fp movw 8(%r8), %sp addw2 %r0, %sp /* make room */ movw %sp, %r0 /* return value */ jmp (%r1) /* continue... */#endif /* ATT3B5 */#ifdef XENIX.386_TEXT segment dword use32 public 'CODE'assume cs:_TEXT;-------------------------------------------------------------------------public _alloca_alloca proc near pop ecx ; return address pop eax ; amount to alloc add eax,3 ; round it to 32-bit boundary and al,11111100B ; mov edx,esp ; current sp in edx sub edx,eax ; lower the stack xchg esp,edx ; start of allocation in esp, old sp in edx mov eax,esp ; return ptr to base in eax push [edx+8] ; save poss. stored reg. values (esi,edi,ebx) push [edx+4] ; on lowered stack push [edx] ; sub esp,4 ; allow for 'add esp, 4' jmp ecx ; jump to return address_alloca endp_TEXT endsend#endif /* XENIX */#endif /* not HAVE_ALLOCA */ :MPW:MPW Tools:Tools with Source:gawk:gawk-2.11:array.c
/* * array.c - routines for associative arrays. *//* * Copyright (C) 1986, 1988, 1989 the Free Software Foundation, Inc. * * This file is part of GAWK, the GNU implementation of the * AWK Progamming Language. * * GAWK is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 1, or (at your option) * any later version. * * GAWK is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with GAWK; see the file COPYING. If not, write to * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */#include "awk.h"#ifdef DONTDEFint primes[] = {31, 61, 127, 257, 509, 1021, 2053, 4099, 8191, 16381};#endif#define ASSOC_HASHSIZE 127#define STIR_BITS(n) ((n) << 5 | (((n) >> 27) & 0x1f))#define HASHSTEP(old, c) ((old << 1) + c)#define MAKE_POS(v) (v & ~0x80000000) /* make number positive */NODE *concat_exp(tree)NODE *tree;{ NODE *r; char *str; char *s; unsigned len; int offset; int subseplen; char *subsep; if (tree->type != Node_expression_list) return force_string(tree_eval(tree)); r = force_string(tree_eval(tree->lnode)); if (tree->rnode == NULL) return r; subseplen = SUBSEP_node->lnode->stlen; subsep = SUBSEP_node->lnode->stptr; len = r->stlen + subseplen + 1; emalloc(str, char *, len, "concat_exp"); memcpy(str, r->stptr, r->stlen+1); s = str + r->stlen; free_temp(r); tree = tree->rnode; while (tree) { if (subseplen == 1) *s++ = *subsep; else { memcpy(s, subsep, subseplen+1); s += subseplen; } r = force_string(tree_eval(tree->lnode)); len += r->stlen + subseplen; offset = s - str; erealloc(str, char *, len, "concat_exp"); s = str + offset; memcpy(s, r->stptr, r->stlen+1); s += r->stlen; free_temp(r); tree = tree->rnode; } r = tmp_string(str, s - str); free(str); return r;}/* Flush all the values in symbol[]doing a split() */voidassoc_clear(symbol)NODE *symbol;{ int i; NODE *bucket, *next; if (symbol->var_array == 0) return; for (i = 0; i < ASSOC_HASHSIZE; i++) { for (bucket = symbol->var_array[i]; bucket; bucket = next) { next = bucket->ahnext; deref = bucket->ahname; do_deref(); deref = bucket->ahvalue; do_deref(); freenode(bucket); } symbol->var_array[i] = 0; }}/* * calculate the hash function of the string subs, also returning in *typtr * the type (string or number) */static inthash_calc(subs)NODE *subs;{ register int hash1 = 0, i; subs = force_string(subs); for (i = 0; i < subs->stlen; i++) hash1 = HASHSTEP(hash1, subs->stptr[i]); hash1 = MAKE_POS(STIR_BITS((int) hash1)) % ASSOC_HASHSIZE; return (hash1);}/* * locate symbol[subs], given hash of subs and type */static NODE * /* NULL if not found */assoc_find(symbol, subs, hash1)NODE *symbol, *subs;int hash1;{ register NODE *bucket; for (bucket = symbol->var_array[hash1]; bucket; bucket = bucket->ahnext) { if (cmp_nodes(bucket->ahname, subs)) continue; return bucket; } return NULL;}/* * test whether the array element symbol[subs] exists or not */intin_array(symbol, subs)NODE *symbol, *subs;{ register int hash1; if (symbol->type == Node_param_list) symbol = stack_ptr[symbol->param_cnt]; if (symbol->var_array == 0) return 0; subs = concat_exp(subs); hash1 = hash_calc(subs); if (assoc_find(symbol, subs, hash1) == NULL) { free_temp(subs); return 0; } else { free_temp(subs); return 1; }}/* * SYMBOL is the address of the node (or other pointer) being dereferenced. * SUBS is a number or string used as the subscript. * * Find SYMBOL[SUBS] in the assoc array. Install it with value "" if it * isn't there. Returns a pointer ala get_lhs to where its value is stored */NODE **assoc_lookup(symbol, subs)NODE *symbol, *subs;{ register int hash1, i; register NODE *bucket; hash1 = hash_calc(subs); if (symbol->var_array == 0) { /* this table really should grow * dynamically */ emalloc(symbol->var_array, NODE **, (sizeof(NODE *) * ASSOC_HASHSIZE), "assoc_lookup"); for (i = 0; i < ASSOC_HASHSIZE; i++) symbol->var_array[i] = 0; symbol->type = Node_var_array; } else { bucket = assoc_find(symbol, subs, hash1); if (bucket != NULL) { free_temp(subs); return &(bucket->ahvalue); } } bucket = newnode(Node_ahash); bucket->ahname = dupnode(subs); bucket->ahvalue = Nnull_string; bucket->ahnext = symbol->var_array[hash1]; symbol->var_array[hash1] = bucket; return &(bucket->ahvalue);}voiddo_delete(symbol, tree)NODE *symbol, *tree;{ register int hash1; register NODE *bucket, *last; NODE *subs; if (symbol->var_array == 0) return; subs = concat_exp(tree); hash1 = hash_calc(subs); last = NULL; for (bucket = symbol->var_array[hash1]; bucket; last = bucket, bucket = bucket->ahnext) if (cmp_nodes(bucket->ahname, subs) == 0) break; free_temp(subs); if (bucket == NULL) return; if (last) last->ahnext = bucket->ahnext; else symbol->var_array[hash1] = bucket->ahnext; deref = bucket->ahname; do_deref(); deref = bucket->ahvalue; do_deref(); freenode(bucket);}struct search *assoc_scan(symbol)NODE *symbol;{ struct search *lookat; if (!symbol->var_array) return 0; emalloc(lookat, struct search *, sizeof(struct search), "assoc_scan"); lookat->numleft = ASSOC_HASHSIZE; lookat->arr_ptr = symbol->var_array; lookat->bucket = symbol->var_array[0]; return assoc_next(lookat);}struct search *assoc_next(lookat)struct search *lookat;{ for (; lookat->numleft; lookat->numleft--) { while (lookat->bucket != 0) { lookat->retval = lookat->bucket->ahname; lookat->bucket = lookat->bucket->ahnext; return lookat; } lookat->bucket = *++(lookat->arr_ptr); } free((char *) lookat); return 0;} :MPW:MPW Tools:Tools with Source:gawk:gawk-2.11:awk.h
/* * awk.h -- Definitions for gawk. *//* * Copyright (C) 1986, 1988, 1989 the Free Software Foundation, Inc. * * This file is part of GAWK, the GNU implementation of the * AWK Progamming Language. * * GAWK is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 1, or (at your option) * any later version. * * GAWK is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with GAWK; see the file COPYING. If not, write to * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* use the following define because the gawk source uses NULL as int */#ifndef NULL#define NULL 0#endif/* ------------------------------ Includes ------------------------------ */#include <stdio.h>#include <stdlib.h>#include <unix.h>#include <string.h>#include <ctype.h>#include <setjmp.h>#ifndef THINK_C#include <varargs.h>#include <types.h>#include <stat.h>#else#include <stdarg.h>#endif#include <errno.h>#include "regex.h"#include "config.h" /* local configuration *//* ------------------- System Functions, Variables, etc ------------------- *//* nasty nasty SunOS-ism */#ifdef sparc#include <alloca.h>#ifdef lintextern char *alloca();#endif#elif !defined(THINK_C)extern char *alloca();#endif#ifdef SPRINTF_INTextern int sprintf();#elif !defined(THINK_C) /* not USG *//* nasty nasty berkelixm */#define setjmp _setjmp#define longjmp _longjmpextern char *sprintf();#endif/* * if you don't have vprintf, but you are BSD, the version defined in * vprintf.c should do the trick. Otherwise, use this and cross your fingers. */#if defined(VPRINTF_MISSING) && !defined(DOPRNT_MISSING) && !defined(BSDSTDIO)#define vfprintf(fp,fmt,arg) _doprnt((fmt), (arg), (fp))#endif#if defined (__STDC__) || defined(THINK_C)#ifndef THINK_Cextern void *malloc(unsigned), *realloc(void *, unsigned);extern void free(char *);#endifextern char *getenv(char *);#ifndef THINK_Cextern char *strcpy(char *, char *), *strcat(char *, char *), *strncpy(char *, char *, int);extern int strcmp(char *, char *);extern int strncmp(char *, char *, int);extern int strncasecmp(char *, char *, int);extern char *strerror(int);extern char *strchr(char *, int);extern int strlen(char *);extern char *memcpy(char *, char *, int);extern int memcmp(char *, char *, int);extern char *memset(char *, int, int);#endifextern int fprintf(FILE *, char *, ...);extern int fprintf();extern int vfprintf();#ifndef MSDOS#ifndef THINK_Cextern int fwrite(char *, int, int, FILE *);#endif#endifextern int fflush(FILE *);extern int fclose(FILE *);extern int pclose(FILE *);#ifndef MSDOSextern int fputs(char *, FILE *);#endifextern void abort();extern int isatty(int);extern void exit(int);extern int system(char *);extern int sscanf( char *, char *, ... );extern double atof(char *);extern int fstat(int, struct stat *);#ifndef THINK_Cextern off_t lseek(int, off_t, int);extern int fseek(FILE *, long, int);extern int close(int);extern int open();extern int pipe(int *);extern int dup2(int, int);#endif#ifndef MSDOSextern int unlink(char *);#endifextern int fork();#ifndef THINK_Cextern int execl( char *, char *, ... );extern int read(int, char *, int);extern int wait(int *);#endifextern void _exit(int);#elseextern void _exit();extern int wait();extern int read();extern int execl();extern int fork();extern int unlink();extern int dup2();extern int pipe();extern int open();extern int close();extern int fseek();extern off_t lseek();extern int fstat();extern void exit();extern int system();extern int isatty();extern void abort();extern int fputs();extern int fclose();extern int pclose();extern int fflush();extern int fwrite();extern int fprintf();extern int vfprintf();extern int sscanf();extern char *malloc(), *realloc();extern void free();extern char *getenv();extern int strcmp();extern int strncmp();extern int strncasecmp();extern int strlen();extern char *strcpy(), *strcat(), *strncpy();extern char *memset();extern int memcmp();extern char *memcpy();extern char *strerror();extern char *strchr();extern double atof();#endif#ifndef MSDOSextern int errno;#endif /* MSDOS *//* ------------------ Constants, Structures, Typedefs ------------------ */#define AWKNUM doubletypedef enum { /* illegal entry == 0 */ Node_illegal, /* binary operators lnode and rnode are the expressions to work on */ Node_times, Node_quotient, Node_mod, Node_plus, Node_minus, Node_cond_pair, /* conditional pair (see Node_line_range) */ Node_subscript, Node_concat, Node_exp, /* unary operators subnode is the expression to work on *//*10*/ Node_preincrement, Node_predecrement, Node_postincrement, Node_postdecrement, Node_unary_minus, Node_field_spec, /* assignments lnode is the var to assign to, rnode is the exp */ Node_assign, Node_assign_times, Node_assign_quotient, Node_assign_mod,/*20*/ Node_assign_plus, Node_assign_minus, Node_assign_exp, /* boolean binaries lnode and rnode are expressions */ Node_and, Node_or, /* binary relationals compares lnode and rnode */ Node_equal, Node_notequal, Node_less, Node_greater, Node_leq,/*30*/ Node_geq, Node_match, Node_nomatch, /* unary relationals works on subnode */ Node_not, /* program structures */ Node_rule_list, /* lnode is a rule, rnode is rest of list */ Node_rule_node, /* lnode is pattern, rnode is statement */ Node_statement_list, /* lnode is statement, rnode is more list */ Node_if_branches, /* lnode is to run on true, rnode on false */ Node_expression_list, /* lnode is an exp, rnode is more list */ Node_param_list, /* lnode is a variable, rnode is more list */ /* keywords *//*40*/ Node_K_if, /* lnode is conditonal, rnode is if_branches */ Node_K_while, /* lnode is condtional, rnode is stuff to run */ Node_K_for, /* lnode is for_struct, rnode is stuff to run */ Node_K_arrayfor, /* lnode is for_struct, rnode is stuff to run */ Node_K_break, /* no subs */ Node_K_continue, /* no stuff */ Node_K_print, /* lnode is exp_list, rnode is redirect */ Node_K_printf, /* lnode is exp_list, rnode is redirect */ Node_K_next, /* no subs */ Node_K_exit, /* subnode is return value, or NULL */ Node_K_do, /* lnode is conditional, rnode stuff to run */ Node_K_return, Node_K_delete, Node_K_getline, Node_K_function, /* lnode is statement list, rnode is params */ /* I/O redirection for print statements */ Node_redirect_output, /* subnode is where to redirect */ Node_redirect_append, /* subnode is where to redirect */ Node_redirect_pipe, /* subnode is where to redirect */ Node_redirect_pipein, /* subnode is where to redirect */ Node_redirect_input, /* subnode is where to redirect */ /* Variables */ Node_var, /* rnode is value, lnode is array stuff */ Node_var_array, /* array is ptr to elements, asize num of * eles */ Node_val, /* node is a value - type in flags */ /* Builtins subnode is explist to work on, proc is func to call */ Node_builtin, /* * pattern: conditional ',' conditional ; lnode of Node_line_range * is the two conditionals (Node_cond_pair), other word (rnode place) * is a flag indicating whether or not this range has been entered. */ Node_line_range, /* * boolean test of membership in array lnode is string-valued * expression rnode is array name */ Node_in_array, Node_func, /* lnode is param. list, rnode is body */ Node_func_call, /* lnode is name, rnode is argument list */ Node_cond_exp, /* lnode is conditonal, rnode is if_branches */ Node_regex, Node_hashnode, Node_ahash} NODETYPE;/* * NOTE - this struct is a rather kludgey -- it is packed to minimize * space usage, at the expense of cleanliness. Alter at own risk. */typedef struct exp_node { union { struct { union { struct exp_node *lptr; char *param_name; char *retext; struct exp_node *nextnode; } l; union { struct exp_node *rptr; struct exp_node *(*pptr) (); struct re_pattern_buffer *preg; struct for_loop_header *hd; struct exp_node **av; int r_ent; /* range entered */ } r; char *name; short number; unsigned char recase; } nodep; struct { AWKNUM fltnum; /* this is here for optimal packing of * the structure on many machines */ char *sp; short slen; unsigned char sref; } val; struct { struct exp_node *next; char *name; int length; struct exp_node *value; } hash;#define hnext sub.hash.next#define hname sub.hash.name#define hlength sub.hash.length#define hvalue sub.hash.value struct { struct exp_node *next; struct exp_node *name; struct exp_node *value; } ahash;#define ahnext sub.ahash.next#define ahname sub.ahash.name#define ahvalue sub.ahash.value } sub; NODETYPE type; unsigned char flags;# define MEM 0x7# define MALLOC 1 /* can be free'd */# define TEMP 2 /* should be free'd */# define PERM 4 /* can't be free'd */# define VAL 0x18# define NUM 8 /* numeric value is valid */# define STR 16 /* string value is valid */# define NUMERIC 32 /* entire field is numeric */} NODE;#define lnode sub.nodep.l.lptr#define nextp sub.nodep.l.nextnode#define rnode sub.nodep.r.rptr#define source_file sub.nodep.name#define source_line sub.nodep.number#define param_cnt sub.nodep.number#define param sub.nodep.l.param_name#define subnode lnode#define proc sub.nodep.r.pptr#define reexp lnode#define rereg sub.nodep.r.preg#define re_case sub.nodep.recase#define re_text sub.nodep.l.retext#define forsub lnode#define forloop rnode->sub.nodep.r.hd#define stptr sub.val.sp#define stlen sub.val.slen#define stref sub.val.sref#define valstat flags#define numbr sub.val.fltnum#define var_value lnode#define var_array sub.nodep.r.av#define condpair lnode#define triggered sub.nodep.r.r_ent#define HASHSIZE 101typedef struct for_loop_header { NODE *init; NODE *cond; NODE *incr;} FOR_LOOP_HEADER;/* for "for(iggy in foo) {" */struct search { int numleft; NODE **arr_ptr; NODE *bucket; NODE *retval;};/* for faster input, bypass stdio */typedef struct iobuf { int fd; char *buf; char *off; int size; /* this will be determined by an fstat() call */ int cnt; char *secbuf; int secsiz; int flag;# define IOP_IS_TTY 1} IOBUF;/* * structure used to dynamically maintain a linked-list of open files/pipes */struct redirect { int flag;# define RED_FILE 1# define RED_PIPE 2# define RED_READ 4# define RED_WRITE 8# define RED_APPEND 16# define RED_NOBUF 32 char *value; FILE *fp; IOBUF *iop; int pid; int status; long offset; /* used for dynamic management of open files */ struct redirect *prev; struct redirect *next;};/* longjmp return codes, must be nonzero *//* Continue means either for loop/while continue, or next input record */#define TAG_CONTINUE 1/* Break means either for/while break, or stop reading input */#define TAG_BREAK 2/* Return means return from a function call; leave value in ret_node */#define TAG_RETURN 3#ifdef MSDOS#define HUGE 0x7fff#else#define HUGE 0x7fffffff#endif/* -------------------------- External variables -------------------------- *//* gawk builtin variables */extern NODE *FS_node, *NF_node, *RS_node, *NR_node;extern NODE *FILENAME_node, *OFS_node, *ORS_node, *OFMT_node;extern NODE *FNR_node, *RLENGTH_node, *RSTART_node, *SUBSEP_node;extern NODE *IGNORECASE_node;extern NODE **stack_ptr;extern NODE *Nnull_string;extern NODE *deref;extern NODE **fields_arr;extern int sourceline;extern char *source;extern NODE *expression_value;extern NODE *variables[];extern NODE *_t; /* used as temporary in tree_eval */extern char *myname;extern int node0_valid;extern int field_num;extern int strict;/* ------------------------- Pseudo-functions ------------------------- */#define is_identchar(c) (isalnum(c) || (c) == '_')#define free_temp(n) if ((n)->flags&TEMP) { deref = (n); do_deref(); } else#define tree_eval(t) (_t = (t),(_t) == NULL ? Nnull_string : \ ((_t)->type == Node_val ? (_t) : r_tree_eval((_t))))#define make_string(s,l) make_str_node((s),(l),0)#define cant_happen() fatal("line %d, file: %s; bailing out", \ __LINE__, __FILE__);#ifdef MEMDEBUG#define memmsg(x,y,z,zz) fprintf(stderr, "malloc: %s: %s: %d %0x\n", z, x, y, zz)#define free(s) fprintf(stderr, "free: s: %0x\n", s), do_free(s)#else#define memmsg(x,y,z,zz)#endif#define emalloc(var,ty,x,str) if ((var = (ty) malloc((unsigned)(x))) == NULL)\ fatal("%s: %s: can't allocate memory (%s)",\ (str), "var", strerror(errno)); else\ memmsg("var", x, str, var)#define erealloc(var,ty,x,str) if((var=(ty)realloc((char *)var,\ (unsigned)(x)))==NULL)\ fatal("%s: %s: can't allocate memory (%s)",\ (str), "var", strerror(errno)); else\ memmsg("re: var", x, str, var)#ifdef DEBUG#define force_number r_force_number#define force_string r_force_string#else#ifdef lintextern AWKNUM force_number();#endif#ifdef MSDOSextern double _msc51bug;#define force_number(n) (_msc51bug=(_t = (n),(_t->flags & NUM) ? _t->numbr : r_force_number(_t)))#else#define force_number(n) (_t = (n),(_t->flags & NUM) ? _t->numbr : r_force_number(_t))#endif#define force_string(s) (_t = (s),(_t->flags & STR) ? _t : r_force_string(_t))#endif#define STREQ(a,b) (*(a) == *(b) && strcmp((a), (b)) == 0)#define STREQN(a,b,n) ((n) && *(a) == *(b) && strncmp((a), (b), (n)) == 0)#define WHOLELINE (node0_valid ? fields_arr[0] : *get_field(0,0))/* ------------- Function prototypes or defs (as appropriate) ------------- */#if defined(__STDC__) || defined (THINK_C)extern int parse_escape(char **);extern int devopen(char *, char *);extern struct re_pattern_buffer *make_regexp(NODE *, int);extern struct re_pattern_buffer *mk_re_parse(char *, int);extern NODE *variable(char *);extern NODE *install(NODE **, char *, NODE *);extern NODE *lookup(NODE **, char *);extern NODE *make_name(char *, NODETYPE);extern int interpret(NODE *);extern NODE *r_tree_eval(NODE *);extern void assign_number(NODE **, double);extern int cmp_nodes(NODE *, NODE *);extern struct redirect *redirect(NODE *, int *);extern int flush_io(void);extern void print_simple(NODE *, FILE *);extern void warning(char *,...); extern void fatal(char *,...); extern void set_record(char *, int);extern NODE **get_field(int, int);extern NODE **get_lhs(NODE *, int);extern void do_deref(void );extern struct search *assoc_scan(NODE *);extern struct search *assoc_next(struct search *);extern NODE **assoc_lookup(NODE *, NODE *);extern double r_force_number(NODE *);extern NODE *r_force_string(NODE *);extern NODE *newnode(NODETYPE);extern NODE *dupnode(NODE *);extern NODE *make_number(double);extern NODE *tmp_number(double);extern NODE *make_str_node(char *, int, int);extern NODE *tmp_string(char *, int);extern char *re_compile_pattern(char *, int, struct re_pattern_buffer *);extern int re_search(struct re_pattern_buffer *, char *, int, int, int, struct re_registers *);extern void freenode(NODE *);#elseextern int parse_escape();extern void freenode();extern int devopen();extern struct re_pattern_buffer *make_regexp();extern struct re_pattern_buffer *mk_re_parse();extern NODE *variable();extern NODE *install();extern NODE *lookup();extern int interpret();extern NODE *r_tree_eval();extern void assign_number();extern int cmp_nodes();extern struct redire
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:gawk:gawk-2.11:awk.h
+++++ Continued from previous card +++++
ct *redirect();extern int flush_io();extern void print_simple();extern void warning();extern void fatal();extern void set_record();extern NODE **get_field();extern NODE **get_lhs();extern void do_deref();extern struct search *assoc_scan();extern struct search *assoc_next();extern NODE **assoc_lookup();extern double r_force_number();extern NODE *r_force_string();extern NODE *newnode();extern NODE *dupnode();extern NODE *make_number();extern NODE *tmp_number();extern NODE *make_str_node();extern NODE *tmp_string();extern char *re_compile_pattern();extern int re_search();#endif#if !defined(__STDC__) && !defined(THINK_C) || __STDC__ <= 0#define volatile#endif/* Figure out what '\a' really is. */#if defined(__STDC__) || defined(THINK_C)#define BELL '\a' /* sure makes life easy, don't it? */#else# if 'z' - 'a' == 25 /* ascii */# if 'a' != 97 /* machine is dumb enough to use mark parity */# define BELL '\207'# else# define BELL '\07'# endif# else# define BELL '\057'# endif#endif#ifndef SIGTYPE#define SIGTYPE void#endifextern char casetable[]; /* for case-independent regexp matching */#include "Prototypes.h" :MPW:MPW Tools:Tools with Source:gawk:gawk-2.11:awk.tab.c
:MPW:MPW Tools:Tools with Source:gawk:gawk-2.11:awk.y
+++++ Continued from previous card +++++
sqrt(), *do_log(), *do_sprintf(), *do_substr(), *do_split(), *do_system(), *do_int(), *do_close(), *do_atan2(), *do_sin(), *do_cos(), *do_rand(), *do_srand(), *do_match(), *do_tolower(), *do_toupper(), *do_sub(), *do_gsub();/* Special functions for debugging */#ifdef DEBUGNODE *do_prvars(), *do_bp();#endif/* Tokentab is sorted ascii ascending order, so it can be binary searched. */static struct token tokentab[] = { { "BEGIN", Node_illegal, LEX_BEGIN, 0, 0 }, { "END", Node_illegal, LEX_END, 0, 0 }, { "atan2", Node_builtin, LEX_BUILTIN, 0, do_atan2 },#ifdef DEBUG { "bp", Node_builtin, LEX_BUILTIN, 0, do_bp },#endif { "break", Node_K_break, LEX_BREAK, 0, 0 }, { "close", Node_builtin, LEX_BUILTIN, 0, do_close }, { "continue", Node_K_continue, LEX_CONTINUE, 0, 0 }, { "cos", Node_builtin, LEX_BUILTIN, 0, do_cos }, { "delete", Node_K_delete, LEX_DELETE, 0, 0 }, { "do", Node_K_do, LEX_DO, 0, 0 }, { "else", Node_illegal, LEX_ELSE, 0, 0 }, { "exit", Node_K_exit, LEX_EXIT, 0, 0 }, { "exp", Node_builtin, LEX_BUILTIN, 0, do_exp }, { "for", Node_K_for, LEX_FOR, 0, 0 }, { "func", Node_K_function, LEX_FUNCTION, 0, 0 }, { "function", Node_K_function, LEX_FUNCTION, 0, 0 }, { "getline", Node_K_getline, LEX_GETLINE, 0, 0 }, { "gsub", Node_builtin, LEX_BUILTIN, 0, do_gsub }, { "if", Node_K_if, LEX_IF, 0, 0 }, { "in", Node_illegal, LEX_IN, 0, 0 }, { "index", Node_builtin, LEX_BUILTIN, 0, do_index }, { "int", Node_builtin, LEX_BUILTIN, 0, do_int }, { "length", Node_builtin, LEX_LENGTH, 0, do_length }, { "log", Node_builtin, LEX_BUILTIN, 0, do_log }, { "match", Node_builtin, LEX_BUILTIN, 0, do_match }, { "next", Node_K_next, LEX_NEXT, 0, 0 }, { "print", Node_K_print, LEX_PRINT, 0, 0 }, { "printf", Node_K_printf, LEX_PRINTF, 0, 0 },#ifdef DEBUG { "prvars", Node_builtin, LEX_BUILTIN, 0, do_prvars },#endif { "rand", Node_builtin, LEX_BUILTIN, 0, do_rand }, { "return", Node_K_return, LEX_RETURN, 0, 0 }, { "sin", Node_builtin, LEX_BUILTIN, 0, do_sin }, { "split", Node_builtin, LEX_BUILTIN, 0, do_split }, { "sprintf", Node_builtin, LEX_BUILTIN, 0, do_sprintf }, { "sqrt", Node_builtin, LEX_BUILTIN, 0, do_sqrt }, { "srand", Node_builtin, LEX_BUILTIN, 0, do_srand }, { "sub", Node_builtin, LEX_BUILTIN, 0, do_sub }, { "substr", Node_builtin, LEX_BUILTIN, 0, do_substr }, { "system", Node_builtin, LEX_BUILTIN, 0, do_system }, { "tolower", Node_builtin, LEX_BUILTIN, 0, do_tolower }, { "toupper", Node_builtin, LEX_BUILTIN, 0, do_toupper }, { "while", Node_K_while, LEX_WHILE, 0, 0 },};static char *token_start;/* VARARGS0 */static voidyyerror(char *fmt,...){ va_list args; char *mesg; register char *ptr, *beg; char *scan;#ifdef THINK_C register int rindex;#endif errcount++; /* Find the current line in the input file */ if (! lexptr) { beg = "(END OF FILE)"; ptr = beg + 13; } else {#ifndef THINK_C if (*lexptr == '\n' && lexptr != lexptr_begin)#else if ( ((*lexptr == '\n') || (*lexptr == '\r')) && lexptr != lexptr_begin)#endif --lexptr;#ifndef THINK_C for (beg = lexptr; beg != lexptr_begin && *beg != '\n'; --beg)#else for (beg = lexptr; beg != lexptr_begin && (*beg != '\n' || *beg != '\r'); --beg)#endif ; /* NL isn't guaranteed */#ifndef THINK_C for (ptr = lexptr; *ptr && *ptr != '\n'; ptr++)#else for (ptr = lexptr; *ptr && (*ptr != '\n' || *ptr != '\r'); ptr++)#endif ; if (beg != lexptr_begin) beg++; }#ifndef THINK_C msg("syntax error near line %d:\n%.*s", lineno, ptr - beg, beg);#else for ( rindex = 0; beg[rindex] != '\0'; rindex++ ) if ( beg[rindex] == '\r' ) beg[rindex] = '\n'; msg("syntax error near line %d:\n%s", lineno, beg);#endif scan = beg; while (scan < token_start) if (*scan++ == '\t') putc('\t', stderr); else putc(' ', stderr); putc('^', stderr); putc(' ', stderr); va_start(args, fmt); vfprintf(stderr, fmt, args); va_end(args); putc('\n', stderr); exit(1);}/* * Parse a C escape sequence. STRING_PTR points to a variable containing a * pointer to the string to parse. That pointer is updated past the * characters we use. The value of the escape sequence is returned. * * A negative value means the sequence \ newline was seen, which is supposed to * be equivalent to nothing at all. * * If \ is followed by a null character, we return a negative value and leave * the string pointer pointing at the null character. * * If \ is followed by 000, we return 0 and leave the string pointer after the * zeros. A value of 0 does not mean end of string. */intparse_escape(string_ptr)char **string_ptr;{ register int c = *(*string_ptr)++; register int i; register int count; switch (c) { case 'a': return BELL; case 'b': return '\b'; case 'f': return '\f'; case 'n': return '\n'; case 'r': return '\r'; case 't': return '\t'; case 'v': return '\v'; case '\n':#ifdef THINK_C case '\r':#endif return -2; case 0: (*string_ptr)--; return -1; case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': i = c - '0'; count = 0; while (++count < 3) { if ((c = *(*string_ptr)++) >= '0' && c <= '7') { i *= 8; i += c - '0'; } else { (*string_ptr)--; break; } } return i; case 'x': i = 0; while (1) { if (isxdigit((c = *(*string_ptr)++))) { if (isdigit(c)) i += c - '0'; else if (isupper(c)) i += c - 'A' + 10; else i += c - 'a' + 10; } else { (*string_ptr)--; break; } } return i; default: return c; }}/* * Read the input and turn it into tokens. Input is now read from a file * instead of from malloc'ed memory. The main program takes a program * passed as a command line argument and writes it to a temp file. Otherwise * the file name is made available in an external variable. */static intyylex(){ register int c; register int namelen; register char *tokstart; char *tokkey; static did_newline = 0; /* the grammar insists that actions end * with newlines. This was easier than * hacking the grammar. */ int seen_e = 0; /* These are for numbers */ int seen_point = 0; int esc_seen; extern char **sourcefile; extern int tempsource, numfiles; static int file_opened = 0; static FILE *fin; static char cbuf[BUFSIZ]; int low, mid, high;#ifdef DEBUG extern int debugging;#endif if (! file_opened) { file_opened = 1;#ifdef DEBUG if (debugging) { int i; for (i = 0; i <= numfiles; i++) fprintf (stderr, "sourcefile[%d] = %s\n", i, sourcefile[i]); }#endif nextfile: if ((fin = pathopen (sourcefile[++curinfile])) == NULL) fatal("cannot open `%s' for reading (%s)", sourcefile[curinfile], strerror(errno)); *(lexptr = cbuf) = '\0'; /* * immediately unlink the tempfile so that it will * go away cleanly if we bomb. */ if (tempsource && curinfile == 0) (void) unlink (sourcefile[curinfile]); }retry: if (! *lexptr) if (fgets (cbuf, sizeof cbuf, fin) == NULL) { if (fin != NULL) fclose (fin); /* be neat and clean */ if (curinfile < numfiles) goto nextfile; return 0; } else lexptr = lexptr_begin = cbuf; if (want_regexp) { int in_brack = 0; want_regexp = 0; token_start = tokstart = lexptr; while (c = *lexptr++) { switch (c) { case '[': in_brack = 1; break; case ']': in_brack = 0; break; case '\\': if (*lexptr++ == '\0') { yyerror("unterminated regexp ends with \\"); return ERROR;#ifndef THINK_C } else if (lexptr[-1] == '\n')#else } else if ((lexptr[-1] == '\n') || (lexptr[-1] == '\r'))#endif goto retry; break; case '/': /* end of the regexp */ if (in_brack) break; lexptr--; yylval.sval = tokstart; return REGEXP; case '\n':#ifdef THINK_C case '\r':#endif lineno++; case '\0': lexptr--; /* so error messages work */ yyerror("unterminated regexp"); return ERROR; } } }#ifndef THINK_C if (*lexptr == '\n') {#else if ((*lexptr == '\n') || (*lexptr == '\r')) {#endif lexptr++; lineno++; return NEWLINE; } while (*lexptr == ' ' || *lexptr == '\t') lexptr++; token_start = tokstart = lexptr; switch (c = *lexptr++) { case 0: return 0; case '\n':#ifdef THINK_C case '\r':#endif lineno++; return NEWLINE; case '#': /* it's a comment */#ifndef THINK_C while (*lexptr != '\n' && *lexptr != '\0')#else while (*lexptr != '\n' && *lexptr != '\0' && *lexptr != '\r' )#endif lexptr++; goto retry; case '\\':#ifndef THINK_C if (*lexptr == '\n') {#else if ( (*lexptr == '\n') || (*lexptr == '\r')) {#endif lineno++; lexptr++; goto retry; } else break; case ')': case ']': case '(': case '[': case '$': case ';': case ':': case '?': /* * set node type to ILLEGAL because the action should set it * to the right thing */ yylval.nodetypeval = Node_illegal; return c; case '{': case ',': yylval.nodetypeval = Node_illegal; return c; case '*': if (*lexptr == '=') { yylval.nodetypeval = Node_assign_times; lexptr++; return ASSIGNOP; } else if (*lexptr == '*') { /* make ** and **= aliases * for ^ and ^= */ if (lexptr[1] == '=') { yylval.nodetypeval = Node_assign_exp; lexptr += 2; return ASSIGNOP; } else { yylval.nodetypeval = Node_illegal; lexptr++; return '^'; } } yylval.nodetypeval = Node_illegal; return c; case '/': if (want_assign && *lexptr == '=') { yylval.nodetypeval = Node_assign_quotient; lexptr++; return ASSIGNOP; } yylval.nodetypeval = Node_illegal; return c; case '%': if (*lexptr == '=') { yylval.nodetypeval = Node_assign_mod; lexptr++; return ASSIGNOP; } yylval.nodetypeval = Node_illegal; return c; case '^': if (*lexptr == '=') { yylval.nodetypeval = Node_assign_exp; lexptr++; return ASSIGNOP; } yylval.nodetypeval = Node_illegal; return c; case '+': if (*lexptr == '=') { yylval.nodetypeval = Node_assign_plus; lexptr++; return ASSIGNOP; } if (*lexptr == '+') { yylval.nodetypeval = Node_illegal; lexptr++; return INCREMENT; } yylval.nodetypeval = Node_illegal; return c; case '!': if (*lexptr == '=') { yylval.nodetypeval = Node_notequal; lexptr++; return RELOP; } if (*lexptr == '~') { yylval.nodetypeval = Node_nomatch; lexptr++; return MATCHOP; } yylval.nodetypeval = Node_illegal; return c; case '<': if (*lexptr == '=') { yylval.nodetypeval = Node_leq; lexptr++; return RELOP; } yylval.nodetypeval = Node_less; return c; case '=': if (*lexptr == '=') { yylval.nodetypeval = Node_equal; lexptr++; return RELOP; } yylval.nodetypeval = Node_assign; return ASSIGNOP; case '>': if (*lexptr == '=') { yylval.nodetypeval = Node_geq; lexptr++; return RELOP; } else if (*lexptr == '>') { yylval.nodetypeval = Node_redirect_append; lexptr++; return APPEND_OP; } yylval.nodetypeval = Node_greater; return c; case '~': yylval.nodetypeval = Node_match; return MATCHOP; case '}': /* * Added did newline stuff. Easier than * hacking the grammar */ if (did_newline) { did_newline = 0; return c; } did_newline++; --lexptr; return NEWLINE; case '"': esc_seen = 0; while (*lexptr != '\0') { switch (*lexptr++) { case '\\': esc_seen = 1;#ifndef THINK_C if (*lexptr == '\n')#else if ((*lexptr == '\n') || (*lexptr == '\r'))#endif yyerror("newline in string"); if (*lexptr++ != '\0') break; /* fall through */ case '\n':#ifdef THINK_C case '\r':#endif lexptr--; yyerror("unterminated string"); return ERROR; case '"': yylval.nodeval = make_str_node(tokstart + 1, lexptr-tokstart-2, esc_seen); yylval.nodeval->flags |= PERM; return YSTRING; } } return ERROR; case '-': if (*lexptr == '=') { yylval.nodetypeval = Node_assign_minus; lexptr++; return ASSIGNOP; } if (*lexptr == '-') { yylval.nodetypeval = Node_illegal; lexptr++; return DECREMENT; } yylval.nodetypeval = Node_illegal; return c; case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': case '.': /* It's a number */ for (namelen = 0; (c = tokstart[namelen]) != '\0'; namelen++) { switch (c) { case '.': if (seen_point) goto got_number; ++seen_point; break; case 'e': case 'E': if (seen_e) goto got_number; ++seen_e; if (tokstart[namelen + 1] == '-' || tokstart[namelen + 1] == '+') namelen++; break; case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': break; default: goto got_number; } }got_number: lexptr = tokstart + namelen; /* yylval.nodeval = make_string(tokstart, namelen); (void) force_number(yylval.nodeval); */ yylval.nodeval = make_number(atof(tokstart)); yylval.nodeval->flags |= PERM; return NUMBER; case '&': if (*lexptr == '&') { yylval.nodetypeval = Node_and; while (c = *++lexptr) { if (c == '#')#ifndef THINK_C while ((c = *++lexptr) != '\n'#else while ((c = *++lexptr) != '\n' && c != '\r'#endif && c != '\0') ;#ifndef THINK_C if (c == '\n')#else if (( c == '\n' ) || ( c == '\r'))#endif lineno++; else if (! isspace(c)) break; } return LEX_AND; } return ERROR; case '|': if (*lexptr == '|') { yylval.nodetypeval = Node_or; while (c = *++lexptr) { if (c == '#')#ifndef THINK_C while ((c = *++lexptr) != '\n'#else while ((c = *++lexptr) != '\n' && c != '\r'#endif && c != '\0') ;#ifndef THINK_C if (c == '\n')#else if (( c == '\n' ) || ( c == '\r'))#endif lineno++; else if (! isspace(c)) break; } return LEX_OR; } yylval.nodetypeval = Node_illegal; return c; } if (c != '_' && ! isalpha(c)) { yyerror("Invalid char '%c' in expression\n", c); return ERROR; } /* it's some type of name-type-thing. Find its length */ for (namelen = 0; is_identchar(tokstart[namelen]); namelen++) /* null */ ; emalloc(tokkey, char *, namelen+1, "yylex"); memcpy(tokkey, tokstart, namelen); tokkey[namelen] = '\0'; /* See if it is a special token. */ low = 0; high = (sizeof (tokentab) / sizeof (tokentab[0])) - 1; while (low <= high) { int i, c; mid = (low + high) / 2; c = *tokstart - tokentab[mid].operator[0]; i = c ? c : strcmp (tokkey, tokentab[mid].operator); if (i < 0) { /* token < mid */ high = mid - 1; } else if (i > 0) { /* token > mid */ low = mid + 1; } else { lexptr = tokstart + namelen; if (strict && tokentab[mid].nostrict) break; if (tokentab[mid].class == LEX_BUILTIN || tokentab[mid].class == LEX_LENGTH) yylval.ptrval = tokentab[mid].ptr; else yylval.nodetypeval = tokentab[mid].value; return tokentab[mid].class; } } /* It's a name. See how long it is. */ yylval.sval = tokkey; lexptr = tokstart + namelen; if (*lexptr == '(') return FUNC_CALL; else return NAME;}#ifndef DEFPATH#ifdef MSDOS#define DEFPATH "."#define ENVSEP ';'#elif defined ( THINK_C )#define DEFPATH "."#define ENVSEP ' '#else#define DEFPATH ".:/usr/lib/awk:/usr/local/lib/awk"#define ENVSEP ':'#endif#endifstatic FILE *pathopen (file)char *file;{ static char *savepath = DEFPATH; static int first = 1; char *awkpath, *cp; char trypath[BUFSIZ]; FILE *fp;#ifdef DEBUG extern int debugging;#endif int fd; if (strcmp (file, "-") == 0) return (stdin); if (strict) return (fopen (file, "r")); if (first) { first = 0; if ((awkpath = getenv ("AWKPAT
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:gawk:gawk-2.11:awk.y
+++++ d from previous card +++++
H")) != NULL && *awkpath) savepath = awkpath; /* used for restarting */ } awkpath = savepath; /* some kind of path name, no search */#ifndef MSDOS if (strchr (file, '/') != NULL)#else if (strchr (file, '/') != NULL || strchr (file, '\\') != NULL || strchr (file, ':') != NULL)#endif return ( (fd = devopen (file, "r")) >= 0 ? fdopen(fd, "r") : NULL); do { trypath[0] = '\0'; /* this should take into account limits on size of trypath */ for (cp = trypath; *awkpath && *awkpath != ENVSEP; ) *cp++ = *awkpath++; if (cp != trypath) { /* nun-null element in path */ *cp++ = '/'; strcpy (cp, file); } else strcpy (trypath, file);#ifdef DEBUG if (debugging) fprintf(stderr, "trying: %s\n", trypath);#endif if ((fd = devopen (trypath, "r")) >= 0 && (fp = fdopen(fd, "r")) != NULL) return (fp); /* no luck, keep going */ if(*awkpath == ENVSEP && awkpath[1] != '\0') awkpath++; /* skip colon */ } while (*awkpath);#ifdef MSDOS /* * Under DOS (and probably elsewhere) you might have one of the awk * paths defined, WITHOUT the current working directory in it. * Therefore you should try to open the file in the current directory. */ return ( (fd = devopen(file, "r")) >= 0 ? fdopen(fd, "r") : NULL);#elif defined ( THINK_C ) /* * Under DOS (and probably elsewhere) you might have one of the awk * paths defined, WITHOUT the current working directory in it. * Therefore you should try to open the file in the current directory. */ return ( (fd = devopen(file, "r")) >= 0 ? fdopen(fd, "r") : NULL);#else return (NULL);#endif}static NODE *node_common(op)NODETYPE op;{ register NODE *r; extern int numfiles; extern int tempsource; extern char **sourcefile; r = newnode(op); r->source_line = lineno; if (numfiles > -1 && ! tempsource) r->source_file = sourcefile[curinfile]; else r->source_file = NULL; return r;}/* * This allocates a node with defined lnode and rnode. * This should only be used by yyparse+co while reading in the program */NODE *node(left, op, right)NODE *left, *right;NODETYPE op;{ register NODE *r; r = node_common(op); r->lnode = left; r->rnode = right; return r;}/* * This allocates a node with defined subnode and proc * Otherwise like node() */static NODE *snode(subn, op, procp)NODETYPE op;NODE *(*procp) ();NODE *subn;{ register NODE *r; r = node_common(op); r->subnode = subn; r->proc = procp; return r;}/* * This allocates a Node_line_range node with defined condpair and * zeroes the trigger word to avoid the temptation of assuming that calling * 'node( foo, Node_line_range, 0)' will properly initialize 'triggered'. *//* Otherwise like node() */static NODE *mkrangenode(cpair)NODE *cpair;{ register NODE *r; r = newnode(Node_line_range); r->condpair = cpair; r->triggered = 0; return r;}/* Build a for loop */static NODE *make_for_loop(init, cond, incr)NODE *init, *cond, *incr;{ register FOR_LOOP_HEADER *r; NODE *n; emalloc(r, FOR_LOOP_HEADER *, sizeof(FOR_LOOP_HEADER), "make_for_loop"); n = newnode(Node_illegal); r->init = init; r->cond = cond; r->incr = incr; n->sub.nodep.r.hd = r; return n;}/* * Install a name in the hash table specified, even if it is already there. * Name stops with first non alphanumeric. Caller must check against * redefinition if that is desired. */NODE *install(table, name, value)NODE **table;char *name;NODE *value;{ register NODE *hp; register int len, bucket; register char *p; len = 0; p = name; while (is_identchar(*p)) p++; len = p - name; hp = newnode(Node_hashnode); bucket = hashf(name, len, HASHSIZE); hp->hnext = table[bucket]; table[bucket] = hp; hp->hlength = len; hp->hvalue = value; emalloc(hp->hname, char *, len + 1, "install"); memcpy(hp->hname, name, len); hp->hname[len] = '\0'; return hp->hvalue;}/* * find the most recent hash node for name name (ending with first * non-identifier char) installed by install */NODE *lookup(table, name)NODE **table;char *name;{ register char *bp; register NODE *bucket; register int len; for (bp = name; is_identchar(*bp); bp++) ; len = bp - name; bucket = table[hashf(name, len, HASHSIZE)]; while (bucket) { if (bucket->hlength == len && STREQN(bucket->hname, name, len)) return bucket->hvalue; bucket = bucket->hnext; } return NULL;}#define HASHSTEP(old, c) ((old << 1) + c)#define MAKE_POS(v) (v & ~0x80000000) /* make number positive *//* * return hash function on name. */static inthashf(name, len, hashsize)register char *name;register int len;int hashsize;{ register int r = 0; while (len--) r = HASHSTEP(r, *name++); r = MAKE_POS(r) % hashsize; return r;}/* * Add new to the rightmost branch of LIST. This uses n^2 time, so we make * a simple attempt at optimizing it. */static NODE *append_right(list, new)NODE *list, *new;{ register NODE *oldlist; static NODE *savefront = NULL, *savetail = NULL; oldlist = list; if (savefront == oldlist) { savetail = savetail->rnode = new; return oldlist; } else savefront = oldlist; while (list->rnode != NULL) list = list->rnode; savetail = list->rnode = new; return oldlist;}/* * check if name is already installed; if so, it had better have Null value, * in which case def is added as the value. Otherwise, install name with def * as value. */static voidfunc_install(params, def)NODE *params;NODE *def;{ NODE *r; pop_params(params->rnode); pop_var(params, 0); r = lookup(variables, params->param); if (r != NULL) { fatal("function name `%s' previously defined", params->param); } else (void) install(variables, params->param, node(params, Node_func, def));}static voidpop_var(np, freeit)NODE *np;int freeit;{ register char *bp; register NODE *bucket, **save; register int len; char *name; name = np->param; for (bp = name; is_identchar(*bp); bp++) ; len = bp - name; save = &(variables[hashf(name, len, HASHSIZE)]); for (bucket = *save; bucket; bucket = bucket->hnext) { if (len == bucket->hlength && STREQN(bucket->hname, name, len)) { *save = bucket->hnext; freenode(bucket); free(bucket->hname); if (freeit) free(np->param); return; } save = &(bucket->hnext); }}static voidpop_params(params)NODE *params;{ register NODE *np; for (np = params; np != NULL; np = np->rnode) pop_var(np, 1);}static NODE *make_param(name)char *name;{ NODE *r; r = newnode(Node_param_list); r->param = name; r->rnode = NULL; r->param_cnt = param_counter++; return (install(variables, name, r));}/* Name points to a variable name. Make sure its in the symbol table */NODE *variable(name)char *name;{ register NODE *r; if ((r = lookup(variables, name)) == NULL) r = install(variables, name, node(Nnull_string, Node_var, (NODE *) NULL)); return r;} :MPW:MPW Tools:Tools with Source:gawk:gawk-2.11:builtin.c
/* * builtin.c - Builtin functions and various utility procedures *//* * Copyright (C) 1986, 1988, 1989 the Free Software Foundation, Inc. * * This file is part of GAWK, the GNU implementation of the * AWK Progamming Language. * * GAWK is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 1, or (at your option) * any later version. * * GAWK is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with GAWK; see the file COPYING. If not, write to * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */#include "awk.h"#ifdef THINK_C#include <math.h>#include <time.h>#endif#ifndef THINK_Cextern void srandom();extern char *initstate();extern char *setstate();extern long random();#endifextern NODE **fields_arr;static void get_one();static void get_two();static int get_three();/* Builtin functions */NODE *do_exp(tree)NODE *tree;{ NODE *tmp; double d, res; double exp(); get_one(tree, &tmp); d = force_number(tmp); free_temp(tmp); errno = 0; res = exp(d); if (errno == ERANGE) warning("exp argument %g is out of range", d); return tmp_number((AWKNUM) res);}NODE *do_index(tree)NODE *tree;{ NODE *s1, *s2; register char *p1, *p2; register int l1, l2; long ret; get_two(tree, &s1, &s2); force_string(s1); force_string(s2); p1 = s1->stptr; p2 = s2->stptr; l1 = s1->stlen; l2 = s2->stlen; ret = 0; if (! strict && IGNORECASE_node->var_value->numbr != 0.0) { while (l1) { if (casetable[*p1] == casetable[*p2] && strncasecmp(p1, p2, l2) == 0) { ret = 1 + s1->stlen - l1; break; } l1--; p1++; } } else { while (l1) { if (STREQN(p1, p2, l2)) { ret = 1 + s1->stlen - l1; break; } l1--; p1++; } } free_temp(s1); free_temp(s2); return tmp_number((AWKNUM) ret);}NODE *do_int(tree)NODE *tree;{ NODE *tmp; double floor(); double d; get_one(tree, &tmp); d = floor((double)force_number(tmp)); free_temp(tmp); return tmp_number((AWKNUM) d);}NODE *do_length(tree)NODE *tree;{ NODE *tmp; int len; get_one(tree, &tmp); len = force_string(tmp)->stlen; free_temp(tmp); return tmp_number((AWKNUM) len);}NODE *do_log(tree)NODE *tree;{ NODE *tmp; double log(); double d, arg; get_one(tree, &tmp); arg = (double) force_number(tmp); if (arg < 0.0) warning("log called with negative argument %g", arg); d = log(arg); free_temp(tmp); return tmp_number((AWKNUM) d);}/* * Note that the output buffer cannot be static because sprintf may get * called recursively by force_string. Hence the wasteful alloca calls *//* %e and %f formats are not properly implemented. Someone should fix them */NODE *do_sprintf(tree)NODE *tree;{#define bchunk(s,l) if(l) {\ while((l)>ofre) {\ char *tmp;\ tmp=(char *)alloca(osiz*2);\ memcpy(tmp,obuf,olen);\ obuf=tmp;\ ofre+=osiz;\ osiz*=2;\ }\ memcpy(obuf+olen,s,(l));\ olen+=(l);\ ofre-=(l);\ } /* Is there space for something L big in the buffer? */#define chksize(l) if((l)>ofre) {\ char *tmp;\ tmp=(char *)alloca(osiz*2);\ memcpy(tmp,obuf,olen);\ obuf=tmp;\ ofre+=osiz;\ osiz*=2;\ } /* * Get the next arg to be formatted. If we've run out of args, * return "" (Null string) */#define parse_next_arg() {\ if(!carg) arg= Nnull_string;\ else {\ get_one(carg,&arg);\ carg=carg->rnode;\ }\ } char *obuf; int osiz, ofre, olen; static char chbuf[] = "0123456789abcdef"; static char sp[] = " "; char *s0, *s1; int n0; NODE *sfmt, *arg; register NODE *carg; long fw, prec, lj, alt, big; long *cur; long val;#ifdef sun386 /* Can't cast unsigned (int/long) from ptr->value */ long tmp_uval; /* on 386i 4.0.1 C compiler -- it just hangs */#endif unsigned long uval; int sgn; int base; char cpbuf[30]; /* if we have numbers bigger than 30 */ char *cend = &cpbuf[30];/* chars, we lose, but seems unlikely */ char *cp; char *fill; double tmpval; char *pr_str; int ucasehex = 0; extern char *gcvt(); obuf = (char *) alloca(120); osiz = 120; ofre = osiz; olen = 0; get_one(tree, &sfmt); sfmt = force_string(sfmt); carg = tree->rnode; for (s0 = s1 = sfmt->stptr, n0 = sfmt->stlen; n0-- > 0;) { if (*s1 != '%') { s1++; continue; } bchunk(s0, s1 - s0); s0 = s1; cur = &fw; fw = 0; prec = 0; lj = alt = big = 0; fill = sp; cp = cend; s1++;retry: --n0; switch (*s1++) { case '%': bchunk("%", 1); s0 = s1; break; case '0': if (fill != sp || lj) goto lose; if (cur == &fw) fill = "0"; /* FALL through */ case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': if (cur == 0) goto lose; *cur = s1[-1] - '0'; while (n0 > 0 && *s1 >= '0' && *s1 <= '9') { --n0; *cur = *cur * 10 + *s1++ - '0'; } goto retry;#ifdef not_yet case ' ': /* print ' ' or '-' */ case '+': /* print '+' or '-' */#endif case '-': if (lj || fill != sp) goto lose; lj++; goto retry; case '.': if (cur != &fw) goto lose; cur = ≺ goto retry; case '#': if (alt) goto lose; alt++; goto retry; case 'l': if (big) goto lose; big++; goto retry; case 'c': parse_next_arg(); if (arg->flags & NUMERIC) {#ifdef sun386 tmp_uval = arg->numbr; uval= (unsigned long) tmp_uval;#else uval = (unsigned long) arg->numbr;#endif cpbuf[0] = uval; prec = 1; pr_str = cpbuf; goto dopr_string; } if (! prec) prec = 1; else if (prec > arg->stlen) prec = arg->stlen; pr_str = arg->stptr; goto dopr_string; case 's': parse_next_arg(); arg = force_string(arg); if (!prec || prec > arg->stlen) prec = arg->stlen; pr_str = arg->stptr; dopr_string: if (fw > prec && !lj) { while (fw > prec) { bchunk(sp, 1); fw--; } } bchunk(pr_str, (int) prec); if (fw > prec) { while (fw > prec) { bchunk(sp, 1); fw--; } } s0 = s1; free_temp(arg); break; case 'd': case 'i': parse_next_arg(); val = (long) force_number(arg); free_temp(arg); if (val < 0) { sgn = 1; val = -val; } else sgn = 0; do { *--cp = '0' + val % 10; val /= 10; } while (val); if (sgn) *--cp = '-'; if (prec > fw) fw = prec; prec = cend - cp; if (fw > prec && !lj) { if (fill != sp && *cp == '-') { bchunk(cp, 1); cp++; prec--; fw--; } while (fw > prec) { bchunk(fill, 1); fw--; } } bchunk(cp, (int) prec); if (fw > prec) { while (fw > prec) { bchunk(fill, 1); fw--; } } s0 = s1; break; case 'u': base = 10; goto pr_unsigned; case 'o': base = 8; goto pr_unsigned; case 'X': ucasehex = 1; case 'x': base = 16; goto pr_unsigned; pr_unsigned: parse_next_arg(); uval = (unsigned long) force_number(arg); free_temp(arg); do { *--cp = chbuf[uval % base]; if (ucasehex && isalpha(*cp)) *cp = toupper(*cp); uval /= base; } while (uval); if (alt && (base == 8 || base == 16)) { if (base == 16) { if (ucasehex) *--cp = 'X'; else *--cp = 'x'; } *--cp = '0'; } prec = cend - cp; if (fw > prec && !lj) { while (fw > prec) { bchunk(fill, 1); fw--; } } bchunk(cp, (int) prec); if (fw > prec) { while (fw > prec) { bchunk(fill, 1); fw--; } } s0 = s1; break; case 'g': parse_next_arg(); tmpval = force_number(arg); free_temp(arg); if (prec == 0) prec = 13; (void) gcvt(tmpval, (int) prec, cpbuf); prec = strlen(cpbuf); cp = cpbuf; if (fw > prec && !lj) { if (fill != sp && *cp == '-') { bchunk(cp, 1); cp++; prec--; } /* Deal with .5 as 0.5 */ if (fill == sp && *cp == '.') { --fw; while (--fw >= prec) { bchunk(fill, 1); } bchunk("0", 1); } else while (fw-- > prec) bchunk(fill, 1); } else {/* Turn .5 into 0.5 */ /* FOO */ if (*cp == '.' && fill == sp) { bchunk("0", 1); --fw; } } bchunk(cp, (int) prec); if (fw > prec) while (fw-- > prec) bchunk(fill, 1); s0 = s1; break; case 'f': parse_next_arg(); tmpval = force_number(arg); free_temp(arg); chksize(fw + prec + 5); /* 5==slop */ cp = cpbuf; *cp++ = '%'; if (lj) *cp++ = '-'; if (fill != sp) *cp++ = '0'; if (cur != &fw) { (void) strcpy(cp, "*.*f"); (void) sprintf(obuf + olen, cpbuf, (int) fw, (int) prec, (double) tmpval); } else { (void) strcpy(cp, "*f"); (void) sprintf(obuf + olen, cpbuf, (int) fw, (double) tmpval); } ofre -= strlen(obuf + olen); olen += strlen(obuf + olen); /* There may be nulls */ s0 = s1; break; case 'e': parse_next_arg(); tmpval = force_number(arg); free_temp(arg); chksize(fw + prec + 5); /* 5==slop */ cp = cpbuf; *cp++ = '%'; if (lj) *cp++ = '-'; if (fill != sp) *cp++ = '0'; if (cur != &fw) { (void) strcpy(cp, "*.*e"); (void) sprintf(obuf + olen, cpbuf, (int) fw, (int) prec, (double) tmpval); } else { (void) strcpy(cp, "*e"); (void) sprintf(obuf + olen, cpbuf, (int) fw, (double) tmpval); } ofre -= strlen(obuf + olen); olen += strlen(obuf + olen); /* There may be nulls */ s0 = s1; break; default: lose: break; } } bchunk(s0, s1 - s0); free_temp(sfmt); return tmp_string(obuf, olen);}voiddo_printf(tree)NODE *tree;{ struct redirect *rp = NULL; register FILE *fp = stdout; int errflg = 0; /* not used, sigh */ if (tree->rnode) { rp = redirect(tree->rnode, &errflg); if (rp) fp = rp->fp; } if (fp) print_simple(do_sprintf(tree->lnode), fp); if (rp && (rp->flag & RED_NOBUF)) fflush(fp);}NODE *do_sqrt(tree)NODE *tree;{ NODE *tmp; double sqrt(); double d, arg; get_one(tree, &tmp); arg = (double) force_number(tmp); if (arg < 0.0) warning("sqrt called with negative argument %g", arg); d = sqrt(arg); free_temp(tmp); return tmp_number((AWKNUM) d);}NODE *do_substr(tree)NODE *tree;{ NODE *t1, *t2, *t3; NODE *r; register int indx, length; t1 = t2 = t3 = NULL; length = -1; if (get_three(tree, &t1, &t2, &t3) == 3) length = (int) force_number(t3); indx = (int) force_number(t2) - 1; t1 = force_string(t1); if (length == -1) length = t1->stlen; if (indx < 0) indx = 0; if (indx >= t1->stlen || length <= 0) { if (t3) free_temp(t3); free_temp(t2); free_temp(t1); return Nnull_string; } if (indx + length > t1->stlen) length = t1->stlen - indx; if (t3) free_temp(t3); free_temp(t2); r = tmp_string(t1->stptr + indx, length); free_temp(t1); return r;}NODE *do_system(tree)NODE *tree;{#if defined(unix) || defined(MSDOS) /* || defined(gnu) */ NODE *tmp; int ret; (void) flush_io (); /* so output is synchronous with gawk's */ get_one(tree, &tmp); ret = system(force_string(tmp)->stptr); ret = (ret >> 8) & 0xff; free_temp(tmp); return tmp_number((AWKNUM) ret);#else fatal("the \"system\" function is not supported."); /* NOTREACHED */#endif}void do_print(tree)register NODE *tree;{ struct redirect *rp = NULL; register FILE *fp = stdout; int errflg = 0; /* not used, sigh */ if (tree->rnode) { rp = redirect(tree->rnode, &errflg); if (rp) fp = rp->fp; } if (!fp) return; tree = tree->lnode; if (!tree) tree = WHOLELINE; if (tree->type != Node_expression_list) { if (!(tree->flags & STR)) cant_happen(); print_simple(tree, fp); } else { while (tree) { print_simple(force_string(tree_eval(tree->lnode)), fp); tree = tree->rnode; if (tree) print_simple(OFS_node->var_value, fp); } } print_simple(ORS_node->var_value, fp); if (rp && (rp->flag & RED_NOBUF)) fflush(fp);}NODE *do_tolower(tree)NODE *tree;{ NODE *t1, *t2; register char *cp, *cp2; get_one(tree, &t1); t1 = force_string(t1); t2 = tmp_string(t1->stptr, t1->stlen); for (cp = t2->stptr, cp2 = t2->stptr + t2->stlen; cp < cp2; cp++) if (isupper(*cp)) *cp = tolower(*cp); free_temp(t1); return t2;}NODE *do_toupper(tree)NODE *tree;{ NODE *t1, *t2; register char *cp; get_one(tree, &t1); t1 = force_string(t1); t2 = tmp_string(t1->stptr, t1->stlen); for (cp = t2->stptr; cp < t2->stptr + t2->stlen; cp++) if (islower(*cp)) *cp = toupper(*cp); free_temp(t1); return t2;}/* * Get the arguments to functions. No function cares if you give it too many * args (they're ignored). Only a few fuctions complain about being given * too few args. The rest have defaults. */static voidget_one(tree, res)NODE *tree, **res;{ if (!tree) { *res = WHOLELINE; return; } *res = tree_eval(tree->lnode);}static voidget_two(tree, res1, res2)NODE *tree, **res1, **res2;{ if (!tree) { *res1 = WHOLELINE; return; } *res1 = tree_eval(tree->lnode); if (!tree->rnode) return; tree = tree->rnode; *res2 = tree_eval(tree->lnode);}static intget_three(tree, res1, res2, res3)NODE *tree, **res1, **res2, **res3;{ if (!tree) { *res1 = WHOLELINE; return 0; } *res1 = tree_eval(tree->lnode); if (!tree->rnode) return 1; tree = tree->rnode; *res2 = tree_eval(tree->lnode); if (!tree->rnode) return 2; tree = tree->rnode; *res3 = tree_eval(tree->lnode); return 3;}inta_get_three(tree, res1, res2, res3)NODE *tree, **res1, **res2, **res3;{ if (!tree) { *res1 = WHOLELINE; return 0; } *res1 = tree_eval(tree->lnode); if (!tree->rnode) return 1; tree = tree->rnode; *res2 = tree->lnode; if (!tree->rnode) return 2; tree = tree->rnode; *res3 = tree_eval(tree->lnode); return 3;}voidprint_simple(tree, fp)NODE *tree;FILE *fp;{ if (fwrite(tree->stptr, sizeof(char), tree->stlen, fp) != tree->stlen) warning("fwrite: %s", strerror(errno)); free_temp(tree);}NODE *do_atan2(tree)NODE *tree;{ NODE *t1, *t2; extern double atan2(); double d1, d2; get_two(tree, &t1, &t2); d1 = force_number(t1); d2 = force_number(t2); free_temp(t1); free_temp(t2); return tmp_number((AWKNUM) atan2(d1, d2));}NODE *do_sin(tree)NODE *tree;{ NODE *tmp; extern double sin(); double d; get_one(tree, &tmp); d = sin((double)force_number(tmp)); free_temp(tmp); return tmp_number((AWKNUM) d);}NODE *do_cos(tree)NODE *tree;{ NODE *tmp; extern double cos(); double d; get_one(tree, &tmp); d = cos((double)force_number(tmp)); free_temp(tmp); return tmp_number((AWKNUM) d);}static int firstrand = 1;static char state[256];#define MAXLONG 2147483647 /* maximum value for long int *//* ARGSUSED */NODE *do_rand(tree)NODE *tree;{ if (firstrand) { (void) initstate((unsigned) 1, state, sizeof state); srandom(1); firstrand = 0; } return tmp_number((AWKNUM) random() / MAXLONG);}NODE *do_srand(tree)NODE *tree;{ NODE *tmp; static long save_seed = 1; long ret = save_seed; /* SVR4 awk srand returns previous seed */#ifndef THINK_C extern long time();#endif if (firstrand) (void) initstate((unsigned) 1, state, sizeof state); else (void) setstate(state); if (!tree)#ifndef THINK_C srandom((int) (save_seed = time((long *) 0)));#else srandom((int) (save_seed = time((time_t *) 0)));#endif else { get_one(tree, &tmp); srandom((int) (save_seed = (long) force_number(tmp))); free_temp(tmp); } firstrand = 0; return tmp_number((AWKNUM) ret);}NODE *do_match(tree)NODE *tree;{ NODE *t1; int rstart; struc
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:gawk:gawk-2.11:builtin.c
+++++ Continued from previous card +++++
t re_registers reregs; struct re_pattern_buffer *rp; int need_to_free = 0; t1 = force_string(tree_eval(tree->lnode)); tree = tree->rnode; if (tree == NULL || tree->lnode == NULL) fatal("match called with only one argument"); tree = tree->lnode; if (tree->type == Node_regex) { rp = tree->rereg; if (!strict && ((IGNORECASE_node->var_value->numbr != 0) ^ (tree->re_case != 0))) { /* recompile since case sensitivity differs */ rp = tree->rereg = mk_re_parse(tree->re_text, (IGNORECASE_node->var_value->numbr != 0)); tree->re_case = (IGNORECASE_node->var_value->numbr != 0); } } else { need_to_free = 1; rp = make_regexp(force_string(tree_eval(tree)), (IGNORECASE_node->var_value->numbr != 0)); if (rp == NULL) cant_happen(); } rstart = re_search(rp, t1->stptr, t1->stlen, 0, t1->stlen, &reregs); free_temp(t1); if (rstart >= 0) { rstart++; /* 1-based indexing */ /* RSTART set to rstart below */ RLENGTH_node->var_value->numbr = (AWKNUM) (reregs.end[0] - reregs.start[0]); } else { /* * Match failed. Set RSTART to 0, RLENGTH to -1. * Return the value of RSTART. */ rstart = 0; /* used as return value */ RLENGTH_node->var_value->numbr = -1.0; } RSTART_node->var_value->numbr = (AWKNUM) rstart; if (need_to_free) { free(rp->buffer); free(rp->fastmap); free((char *) rp); } return tmp_number((AWKNUM) rstart);}static NODE *sub_common(tree, global)NODE *tree;int global;{ register int len; register char *scan; register char *bp, *cp; int search_start = 0; int match_length; int matches = 0; char *buf; struct re_pattern_buffer *rp; NODE *s; /* subst. pattern */ NODE *t; /* string to make sub. in; $0 if none given */ struct re_registers reregs; unsigned int saveflags; NODE *tmp; NODE **lhs; char *lastbuf; int need_to_free = 0; if (tree == NULL) fatal("sub or gsub called with 0 arguments"); tmp = tree->lnode; if (tmp->type == Node_regex) { rp = tmp->rereg; if (! strict && ((IGNORECASE_node->var_value->numbr != 0) ^ (tmp->re_case != 0))) { /* recompile since case sensitivity differs */ rp = tmp->rereg = mk_re_parse(tmp->re_text, (IGNORECASE_node->var_value->numbr != 0)); tmp->re_case = (IGNORECASE_node->var_value->numbr != 0); } } else { need_to_free = 1; rp = make_regexp(force_string(tree_eval(tmp)), (IGNORECASE_node->var_value->numbr != 0)); if (rp == NULL) cant_happen(); } tree = tree->rnode; if (tree == NULL) fatal("sub or gsub called with only 1 argument"); s = force_string(tree_eval(tree->lnode)); tree = tree->rnode; deref = 0; field_num = -1; if (tree == NULL) { t = node0_valid ? fields_arr[0] : *get_field(0, 0); lhs = &fields_arr[0]; field_num = 0; deref = t; } else { t = tree->lnode; lhs = get_lhs(t, 1); t = force_string(tree_eval(t)); } /* * create a private copy of the string */ if (t->stref > 1 || (t->flags & PERM)) { saveflags = t->flags; t->flags &= ~MALLOC; tmp = dupnode(t); t->flags = saveflags; do_deref(); t = tmp; if (lhs) *lhs = tmp; } lastbuf = t->stptr; do { if (re_search(rp, t->stptr, t->stlen, search_start, t->stlen-search_start, &reregs) == -1 || reregs.start[0] == reregs.end[0]) break; matches++; /* * first, make a pass through the sub. pattern, to calculate * the length of the string after substitution */ match_length = reregs.end[0] - reregs.start[0]; len = t->stlen - match_length; for (scan = s->stptr; scan < s->stptr + s->stlen; scan++) if (*scan == '&') len += match_length; else if (*scan == '\\' && *(scan+1) == '&') { scan++; len++; } else len++; emalloc(buf, char *, len + 1, "do_sub"); bp = buf; /* * now, create the result, copying in parts of the original * string */ for (scan = t->stptr; scan < t->stptr + reregs.start[0]; scan++) *bp++ = *scan; for (scan = s->stptr; scan < s->stptr + s->stlen; scan++) if (*scan == '&') for (cp = t->stptr + reregs.start[0]; cp < t->stptr + reregs.end[0]; cp++) *bp++ = *cp; else if (*scan == '\\' && *(scan+1) == '&') { scan++; *bp++ = *scan; } else *bp++ = *scan; search_start = bp - buf; for (scan = t->stptr + reregs.end[0]; scan < t->stptr + t->stlen; scan++) *bp++ = *scan; *bp = '\0'; free(lastbuf); t->stptr = buf; lastbuf = buf; t->stlen = len; } while (global && search_start < t->stlen); free_temp(s); if (need_to_free) { free(rp->buffer); free(rp->fastmap); free((char *) rp); } if (matches > 0) { if (field_num == 0) set_record(fields_arr[0]->stptr, fields_arr[0]->stlen); t->flags &= ~(NUM|NUMERIC); } field_num = -1; return tmp_number((AWKNUM) matches);}NODE *do_gsub(tree)NODE *tree;{ return sub_common(tree, 1);}NODE *do_sub(tree)NODE *tree;{ return sub_common(tree, 0);} :MPW:MPW Tools:Tools with Source:gawk:gawk-2.11:config.h
/* config.h - contains the defines necessary to compile/* GNU awk. This file is necessary due to Think C's lack/* of a make facility as used in UNIX or MPW. /* * Copyright (C) 1986, 1988, 1989 the Free Software FounInc. * * This file is part of GAWK, the GNU implementation of the * AWK Progamming Language. * * GAWK is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 1, or (at your option) * any later version. * * GAWK is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with GAWK; see the file COPYING. If not, write to * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ /* ------------ defines for routines missing from Think C 4.0 ----------*/#define BCOPY_MISSING#define SPRINTF_INT#define BLKSIZE_MISSING#define DOPRNT_MISSING#define GCVT_MISSING#define GETOPT_MISSING#define RANDOM_MISSING#define STRCASE_MISSING/* ------------- the following is used by alloca.c ---------------------*/#define STACK_DIRECTION -1/* ------------- define debug for all the routines ---------------------*//*#define DEBUG 1*/ :MPW:MPW Tools:Tools with Source:gawk:gawk-2.11:debug.c
/* * debug.c -- Various debugging routines *//* * Copyright (C) 1986, 1988, 1989 the Free Software Foundation, Inc. * * This file is part of GAWK, the GNU implementation of the * AWK Progamming Language. * * GAWK is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 1, or (at your option) * any later version. * * GAWK is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with GAWK; see the file COPYING. If not, write to * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */#include "awk.h"#ifdef DEBUGextern NODE **fields_arr;/* This is all debugging stuff. Ignore it and maybe it'll go away. *//* * Some of it could be turned into a really cute trace command, if anyone * wants to. */char *nnames[] = { "illegal", "times", "quotient", "mod", "plus", "minus", "cond_pair", "subscript", "concat", "exp", /* 10 */ "preincrement", "predecrement", "postincrement", "postdecrement", "unary_minus", "field_spec", "assign", "assign_times", "assign_quotient", "assign_mod", /* 20 */ "assign_plus", "assign_minus", "assign_exp", "and", "or", "equal", "notequal", "less", "greater", "leq", /* 30 */ "geq", "match", "nomatch", "not", "rule_list", "rule_node", "statement_list", "if_branches", "expression_list", "param_list", /* 40 */ "K_if", "K_while", "K_for", "K_arrayfor", "K_break", "K_continue", "K_print", "K_printf", "K_next", "K_exit", /* 50 */ "K_do", "K_return", "K_delete", "K_getline", "K_function", "redirect_output", "redirect_append", "redirect_pipe", "redirect_pipein", "redirect_input", /* 60 */ "var", "var_array", "val", "builtin", "line_range", "in_array", "func", "func_call", "cond_exp", "regex", /* 70 */ "hashnode", "ahash"};ptree(n)NODE *n;{ print_parse_tree(n);}pt(){ long x; (void) scanf("%x", &x); printf("0x%x\n", x); print_parse_tree((NODE *) x); fflush(stdout);}static depth = 0;print_parse_tree(ptr)NODE *ptr;{ if (!ptr) { printf("NULL\n"); return; } if ((int) (ptr->type) < 0 || (int) (ptr->type) > sizeof(nnames) / sizeof(nnames[0])) { printf("(0x%x Type %d??)\n", ptr, ptr->type); return; } printf("(%d)%*s", depth, depth, ""); switch ((int) ptr->type) { case (int) Node_val: printf("(0x%x Value ", ptr); if (ptr->flags&STR) printf("str: \"%.*s\" ", ptr->stlen, ptr->stptr); if (ptr->flags&NUM) printf("num: %g", ptr->numbr); printf(")\n"); return; case (int) Node_var_array: { struct search *l; printf("(0x%x Array)\n", ptr); for (l = assoc_scan(ptr); l; l = assoc_next(l)) { printf("\tindex: "); print_parse_tree(l->retval); printf("\tvalue: "); print_parse_tree(*assoc_lookup(ptr, l->retval)); printf("\n"); } return; } case Node_param_list: printf("(0x%x Local variable %s)\n", ptr, ptr->param); if (ptr->rnode) print_parse_tree(ptr->rnode); return; case Node_regex: printf("(0x%x Regular expression %s\n", ptr, ptr->re_text); return; } if (ptr->lnode) printf("0x%x = left<--", ptr->lnode); printf("(0x%x %s.%d)", ptr, nnames[(int) (ptr->type)], ptr->type); if (ptr->rnode) printf("-->right = 0x%x", ptr->rnode); printf("\n"); depth++; if (ptr->lnode) print_parse_tree(ptr->lnode); switch ((int) ptr->type) { case (int) Node_line_range: case (int) Node_match: case (int) Node_nomatch: break; case (int) Node_builtin: printf("Builtin: %d\n", ptr->proc); break; case (int) Node_K_for: case (int) Node_K_arrayfor: printf("(%s:)\n", nnames[(int) (ptr->type)]); print_parse_tree(ptr->forloop->init); printf("looping:\n"); print_parse_tree(ptr->forloop->cond); printf("doing:\n"); print_parse_tree(ptr->forloop->incr); break; default: if (ptr->rnode) print_parse_tree(ptr->rnode); break; } --depth;}/* * print out all the variables in the world */dump_vars(){ register int n; register NODE *buc;#ifdef notdef printf("Fields:"); dump_fields();#endif printf("Vars:\n"); for (n = 0; n < HASHSIZE; n++) { for (buc = variables[n]; buc; buc = buc->hnext) { printf("'%.*s': ", buc->hlength, buc->hname); print_parse_tree(buc->hvalue); } } printf("End\n");}#ifdef notdefdump_fields(){ register NODE **p; register int n; printf("%d fields\n", f_arr_siz); for (n = 0, p = &fields_arr[0]; n < f_arr_siz; n++, p++) { printf("$%d is '", n); print_simple(*p, stdout); printf("'\n"); }}#endif/* VARARGS1 */print_debug(str, n)char *str;{ extern int debugging; if (debugging) printf("%s:0x%x\n", str, n);}int indent = 0;print_a_node(ptr)NODE *ptr;{ NODE *p1; char *str, *str2; int n; NODE *buc; if (!ptr) return; /* don't print null ptrs */ switch (ptr->type) { case Node_val: if (ptr->flags&NUM) printf("%g", ptr->numbr); else printf("\"%.*s\"", ptr->stlen, ptr->stptr); return; case Node_times: str = "*"; goto pr_twoop; case Node_quotient: str = "/"; goto pr_twoop; case Node_mod: str = "%"; goto pr_twoop; case Node_plus: str = "+"; goto pr_twoop; case Node_minus: str = "-"; goto pr_twoop; case Node_exp: str = "^"; goto pr_twoop; case Node_concat: str = " "; goto pr_twoop; case Node_assign: str = "="; goto pr_twoop; case Node_assign_times: str = "*="; goto pr_twoop; case Node_assign_quotient: str = "/="; goto pr_twoop; case Node_assign_mod: str = "%="; goto pr_twoop; case Node_assign_plus: str = "+="; goto pr_twoop; case Node_assign_minus: str = "-="; goto pr_twoop; case Node_assign_exp: str = "^="; goto pr_twoop; case Node_and: str = "&&"; goto pr_twoop; case Node_or: str = "||"; goto pr_twoop; case Node_equal: str = "=="; goto pr_twoop; case Node_notequal: str = "!="; goto pr_twoop; case Node_less: str = "<"; goto pr_twoop; case Node_greater: str = ">"; goto pr_twoop; case Node_leq: str = "<="; goto pr_twoop; case Node_geq: str = ">="; goto pr_twoop;pr_twoop: print_a_node(ptr->lnode); printf("%s", str); print_a_node(ptr->rnode); return; case Node_not: str = "!"; str2 = ""; goto pr_oneop; case Node_field_spec: str = "$("; str2 = ")"; goto pr_oneop; case Node_postincrement: str = ""; str2 = "++"; goto pr_oneop; case Node_postdecrement: str = ""; str2 = "--"; goto pr_oneop; case Node_preincrement: str = "++"; str2 = ""; goto pr_oneop; case Node_predecrement: str = "--"; str2 = ""; goto pr_oneop;pr_oneop: printf(str); print_a_node(ptr->subnode); printf(str2); return; case Node_expression_list: print_a_node(ptr->lnode); if (ptr->rnode) { printf(","); print_a_node(ptr->rnode); } return; case Node_var: for (n = 0; n < HASHSIZE; n++) { for (buc = variables[n]; buc; buc = buc->hnext) { if (buc->hvalue == ptr) { printf("%.*s", buc->hlength, buc->hname); n = HASHSIZE; break; } } } return; case Node_subscript: print_a_node(ptr->lnode); printf("["); print_a_node(ptr->rnode); printf("]"); return; case Node_builtin: printf("some_builtin("); print_a_node(ptr->subnode); printf(")"); return; case Node_statement_list: printf("{\n"); indent++; for (n = indent; n; --n) printf(" "); while (ptr) { print_maybe_semi(ptr->lnode); if (ptr->rnode) for (n = indent; n; --n) printf(" "); ptr = ptr->rnode; } --indent; for (n = indent; n; --n) printf(" "); printf("}\n"); for (n = indent; n; --n) printf(" "); return; case Node_K_if: printf("if("); print_a_node(ptr->lnode); printf(") "); ptr = ptr->rnode; if (ptr->lnode->type == Node_statement_list) { printf("{\n"); indent++; for (p1 = ptr->lnode; p1; p1 = p1->rnode) { for (n = indent; n; --n) printf(" "); print_maybe_semi(p1->lnode); } --indent; for (n = indent; n; --n) printf(" "); if (ptr->rnode) { printf("} else "); } else { printf("}\n"); return; } } else { print_maybe_semi(ptr->lnode); if (ptr->rnode) { for (n = indent; n; --n) printf(" "); printf("else "); } else return; } if (!ptr->rnode) return; deal_with_curls(ptr->rnode); return; case Node_K_while: printf("while("); print_a_node(ptr->lnode); printf(") "); deal_with_curls(ptr->rnode); return; case Node_K_do: printf("do "); deal_with_curls(ptr->rnode); printf("while("); print_a_node(ptr->lnode); printf(") "); return; case Node_K_for: printf("for("); print_a_node(ptr->forloop->init); printf(";"); print_a_node(ptr->forloop->cond); printf(";"); print_a_node(ptr->forloop->incr); printf(") "); deal_with_curls(ptr->forsub); return; case Node_K_arrayfor: printf("for("); print_a_node(ptr->forloop->init); printf(" in "); print_a_node(ptr->forloop->incr); printf(") "); deal_with_curls(ptr->forsub); return; case Node_K_printf: printf("printf("); print_a_node(ptr->lnode); printf(")"); return; case Node_K_print: printf("print("); print_a_node(ptr->lnode); printf(")"); return; case Node_K_next: printf("next"); return; case Node_K_break: printf("break"); return; case Node_K_delete: printf("delete "); print_a_node(ptr->lnode); return; case Node_func: printf("function %s (", ptr->lnode->param); if (ptr->lnode->rnode) print_a_node(ptr->lnode->rnode); printf(")\n"); print_a_node(ptr->rnode); return; case Node_param_list: printf("%s", ptr->param); if (ptr->rnode) { printf(", "); print_a_node(ptr->rnode); } return; default: print_parse_tree(ptr); return; }}print_maybe_semi(ptr)NODE *ptr;{ print_a_node(ptr); switch (ptr->type) { case Node_K_if: case Node_K_for: case Node_K_arrayfor: case Node_statement_list: break; default: printf(";\n"); break; }}deal_with_curls(ptr)NODE *ptr;{ int n; if (ptr->type == Node_statement_list) { printf("{\n"); indent++; while (ptr) { for (n = indent; n; --n) printf(" "); print_maybe_semi(ptr->lnode); ptr = ptr->rnode; } --indent; for (n = indent; n; --n) printf(" "); printf("}\n"); } else { print_maybe_semi(ptr); }}NODE *do_prvars(){ dump_vars(); return Nnull_string;}NODE *do_bp(){ return Nnull_string;}#endif#ifdef MEMDEBUG#undef freeextern void free();voiddo_free(s)char *s;{ free(s);}#endif :MPW:MPW Tools:Tools with Source:gawk:gawk-2.11:eval.c
/* * eval.c - gawk parse tree interpreter *//* * Copyright (C) 1986, 1988, 1989 the Free Software Foundation, Inc. * * This file is part of GAWK, the GNU implementation of the * AWK Progamming Language. * * GAWK is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 1, or (at your option) * any later version. * * GAWK is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with GAWK; see the file COPYING. If not, write to * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */#include "awk.h"#include <math.h>extern void do_print();extern void do_printf();extern NODE *do_match();extern NODE *do_sub();extern NODE *do_getline();extern NODE *concat_exp();extern int in_array();extern void do_delete();extern double pow();static int eval_condition();static NODE *op_assign();static NODE *func_call();static NODE *match_op();NODE *_t; /* used as a temporary in macros */#ifdef MSDOSdouble _msc51bug; /* to get around a bug in MSC 5.1 */#endifNODE *ret_node;/* More of that debugging stuff */#ifdef DEBUG#define DBG_P(X) print_debug X#else#define DBG_P(X)#endif/* Macros and variables to save and restore function and loop bindings *//* * the val variable allows return/continue/break-out-of-context to be * caught and diagnosed */#define PUSH_BINDING(stack, x, val) (memcpy ((char *)(stack), (char *)(x), sizeof (jmp_buf)), val++)#define RESTORE_BINDING(stack, x, val) (memcpy ((char *)(x), (char *)(stack), sizeof (jmp_buf)), val--)static jmp_buf loop_tag; /* always the current binding */static int loop_tag_valid = 0; /* nonzero when loop_tag valid */static int func_tag_valid = 0;static jmp_buf func_tag;extern int exiting, exit_val;/* * This table is used by the regexp routines to do case independant * matching. Basically, every ascii character maps to itself, except * uppercase letters map to lower case ones. This table has 256 * entries, which may be overkill. Note also that if the system this * is compiled on doesn't use 7-bit ascii, casetable[] should not be * defined to the linker, so gawk should not load. * * Do NOT make this array static, it is used in several spots, not * just in this file. */#if 'a' == 97 /* it's ascii */char casetable[] = { '\000', '\001', '\002', '\003', '\004', '\005', '\006', '\007', '\010', '\011', '\012', '\013', '\014', '\015', '\016', '\017', '\020', '\021', '\022', '\023', '\024', '\025', '\026', '\027', '\030', '\031', '\032', '\033', '\034', '\035', '\036', '\037', /* ' ' '!' '"' '#' '$' '%' '&' ''' */ '\040', '\041', '\042', '\043', '\044', '\045', '\046', '\047', /* '(' ')' '*' '+' ',' '-' '.' '/' */ '\050', '\051', '\052', '\053', '\054', '\055', '\056', '\057', /* '0' '1' '2' '3' '4' '5' '6' '7' */ '\060', '\061', '\062', '\063', '\064', '\065', '\066', '\067', /* '8' '9' ':' ';' '<' '=' '>' '?' */ '\070', '\071', '\072', '\073', '\074', '\075', '\076', '\077', /* '@' 'A' 'B' 'C' 'D' 'E' 'F' 'G' */ '\100', '\141', '\142', '\143', '\144', '\145', '\146', '\147', /* 'H' 'I' 'J' 'K' 'L' 'M' 'N' 'O' */ '\150', '\151', '\152', '\153', '\154', '\155', '\156', '\157', /* 'P' 'Q' 'R' 'S' 'T' 'U' 'V' 'W' */ '\160', '\161', '\162', '\163', '\164', '\165', '\166', '\167', /* 'X' 'Y' 'Z' '[' '\' ']' '^' '_' */ '\170', '\171', '\172', '\133', '\134', '\135', '\136', '\137', /* '`' 'a' 'b' 'c' 'd' 'e' 'f' 'g' */ '\140', '\141', '\142', '\143', '\144', '\145', '\146', '\147', /* 'h' 'i' 'j' 'k' 'l' 'm' 'n' 'o' */ '\150', '\151', '\152', '\153', '\154', '\155', '\156', '\157', /* 'p' 'q' 'r' 's' 't' 'u' 'v' 'w' */ '\160', '\161', '\162', '\163', '\164', '\165', '\166', '\167', /* 'x' 'y' 'z' '{' '|' '}' '~' */ '\170', '\171', '\172', '\173', '\174', '\175', '\176', '\177', '\200', '\201', '\202', '\203', '\204', '\205', '\206', '\207', '\210', '\211', '\212', '\213', '\214', '\215', '\216', '\217', '\220', '\221', '\222', '\223', '\224', '\225', '\226', '\227', '\230', '\231', '\232', '\233', '\234', '\235', '\236', '\237', '\240', '\241', '\242', '\243', '\244', '\245', '\246', '\247', '\250', '\251', '\252', '\253', '\254', '\255', '\256', '\257', '\260', '\261', '\262', '\263', '\264', '\265', '\266', '\267', '\270', '\271', '\272', '\273', '\274', '\275', '\276', '\277', '\300', '\301', '\302', '\303', '\304', '\305', '\306', '\307', '\310', '\311', '\312', '\313', '\314', '\315', '\316', '\317', '\320', '\321', '\322', '\323', '\324', '\325', '\326', '\327', '\330', '\331', '\332', '\333', '\334', '\335', '\336', '\337', '\340', '\341', '\342', '\343', '\344', '\345', '\346', '\347', '\350', '\351', '\352', '\353', '\354', '\355', '\356', '\357', '\360', '\361', '\362', '\363', '\364', '\365', '\366', '\367', '\370', '\371', '\372', '\373', '\374', '\375', '\376', '\377',};#else#include "You lose. You will need a translation table for your character set."#endif/* * Tree is a bunch of rules to run. Returns zero if it hit an exit() * statement */intinterpret(tree)NODE *tree;{ volatile jmp_buf loop_tag_stack; /* shallow binding stack for loop_tag */ static jmp_buf rule_tag;/* tag the rule currently being run, for NEXT * and EXIT statements. It is static because * there are no nested rules */ register NODE *t = NULL;/* temporary */ volatile NODE **lhs; /* lhs == Left Hand Side for assigns, etc */ volatile struct search *l; /* For array_for */ volatile NODE *stable_tree; if (tree == NULL) return 1; sourceline = tree->source_line; source = tree->source_file; switch (tree->type) { case Node_rule_list: for (t = tree; t != NULL; t = t->rnode) { tree = t->lnode; /* FALL THROUGH */ case Node_rule_node: sourceline = tree->source_line; source = tree->source_file; switch (setjmp(rule_tag)) { case 0: /* normal non-jump */ /* test pattern, if any */ if (tree->lnode == NULL || eval_condition(tree->lnode)) { DBG_P(("Found a rule", (int)tree->rnode)); if (tree->rnode == NULL) { /* * special case: pattern with * no action is equivalent to * an action of {print} */ NODE printnode; printnode.type = Node_K_print; printnode.lnode = NULL; printnode.rnode = NULL; do_print(&printnode); } else if (tree->rnode->type == Node_illegal) { /* * An empty statement * (``{ }'') is different * from a missing statement. * A missing statement is * equal to ``{ print }'' as * above, but an empty * statement is as in C, do * nothing. */ } else (void) interpret(tree->rnode); } break; case TAG_CONTINUE: /* NEXT statement */ return 1; case TAG_BREAK: return 0; default: cant_happen(); } if (t == NULL) break; } break; case Node_statement_list: for (t = tree; t != NULL; t = t->rnode) { DBG_P(("Statements", (int)t->lnode)); (void) interpret(t->lnode); } break; case Node_K_if: DBG_P(("IF", (int)tree->lnode)); if (eval_condition(tree->lnode)) { DBG_P(("True", (int)tree->rnode->lnode)); (void) interpret(tree->rnode->lnode); } else { DBG_P(("False", (int)tree->rnode->rnode)); (void) interpret(tree->rnode->rnode); } break; case Node_K_while: PUSH_BINDING(loop_tag_stack, loop_tag, loop_tag_valid); DBG_P(("WHILE", (int)tree->lnode)); stable_tree = tree; while (eval_condition(stable_tree->lnode)) { switch (setjmp(loop_tag)) { case 0: /* normal non-jump */ DBG_P(("DO", (int)stable_tree->rnode)); (void) interpret(stable_tree->rnode); break; case TAG_CONTINUE: /* continue statement */ break; case TAG_BREAK: /* break statement */ RESTORE_BINDING(loop_tag_stack, loop_tag, loop_tag_valid); return 1; default: cant_happen(); } } RESTORE_BINDING(loop_tag_stack, loop_tag, loop_tag_valid); break; case Node_K_do: PUSH_BINDING(loop_tag_stack, loop_tag, loop_tag_valid); stable_tree = tree; do { switch (setjmp(loop_tag)) { case 0: /* normal non-jump */ DBG_P(("DO", (int)stable_tree->rnode)); (void) interpret(stable_tree->rnode); break; case TAG_CONTINUE: /* continue statement */ break; case TAG_BREAK: /* break statement */ RESTORE_BINDING(loop_tag_stack, loop_tag, loop_tag_valid); return 1; default: cant_happen(); } DBG_P(("WHILE", (int)stable_tree->lnode)); } while (eval_condition(stable_tree->lnode)); RESTORE_BINDING(loop_tag_stack, loop_tag, loop_tag_valid); break; case Node_K_for: PUSH_BINDING(loop_tag_stack, loop_tag, loop_tag_valid); DBG_P(("FOR", (int)tree->forloop->init)); (void) interpret(tree->forloop->init); DBG_P(("FOR.WHILE", (int)tree->forloop->cond)); stable_tree = tree; while (eval_condition(stable_tree->forloop->cond)) { switch (setjmp(loop_tag)) { case 0: /* normal non-jump */ DBG_P(("FOR.DO", (int)stable_tree->lnode)); (void) interpret(stable_tree->lnode); /* fall through */ case TAG_CONTINUE: /* continue statement */ DBG_P(("FOR.INCR", (int)stable_tree->forloop->incr)); (void) interpret(stable_tree->forloop->incr); break; case TAG_BREAK: /* break statement */ RESTORE_BINDING(loop_tag_stack, loop_tag, loop_tag_valid); return 1; default: cant_happen(); } } RESTORE_BINDING(loop_tag_stack, loop_tag, loop_tag_valid); break; case Node_K_arrayfor:#define hakvar forloop->init#define arrvar forloop->incr PUSH_BINDING(loop_tag_stack, loop_tag, loop_tag_valid); DBG_P(("AFOR.VAR", (int)tree->hakvar)); lhs = (volatile NODE **) get_lhs(tree->hakvar, 1); t = tree->arrvar; if (t->type == Node_param_list) t = stack_ptr[t->param_cnt]; stable_tree = tree; for (l = assoc_scan(t); l; l = assoc_next((struct search *)l)) { deref = *((NODE **) lhs); do_deref(); *lhs = dupnode(l->retval); if (field_num == 0) set_record(fields_arr[0]->stptr, fields_arr[0]->stlen); DBG_P(("AFOR.NEXTIS", (int)*lhs)); switch (setjmp(loop_tag)) { case 0: DBG_P(("AFOR.DO", (int)stable_tree->lnode)); (void) interpret(stable_tree->lnode); case TAG_CONTINUE: break; case TAG_BREAK: RESTORE_BINDING(loop_tag_stack, loop_tag, loop_tag_valid); field_num = -1; return 1; default: cant_happen(); } } field_num = -1; RESTORE_BINDING(loop_tag_stack, loop_tag, loop_tag_valid); break; case Node_K_break: DBG_P(("BREAK", (int)NULL)); if (loop_tag_valid == 0) fatal("unexpected break"); longjmp(loop_tag, TAG_BREAK); break; case Node_K_continue: DBG_P(("CONTINUE", (int)NULL)); if (loop_tag_valid == 0) fatal("unexpected continue"); longjmp(loop_tag, TAG_CONTINUE); break; case Node_K_print: DBG_P(("PRINT", (int)tree)); do_print(tree); break; case Node_K_printf: DBG_P(("PRINTF", (int)tree)); do_printf(tree); break; case Node_K_next: DBG_P(("NEXT", (int)NULL)); longjmp(rule_tag, TAG_CONTINUE); break; case Node_K_exit: /* * In A,K,&W, p. 49, it says that an exit statement "... * causes the program to behave as if the end of input had * occurred; no more input is read, and the END actions, if * any are executed." This implies that the rest of the rules * are not done. So we immediately break out of the main loop. */ DBG_P(("EXIT", (int)NULL)); exiting = 1; if (tree) { t = tree_eval(tree->lnode); exit_val = (int) force_number(t); } free_temp(t); longjmp(rule_tag, TAG_BREAK); break; case Node_K_return: DBG_P(("RETURN", (int)NULL)); t = tree_eval(tree->lnode); ret_node = dupnode(t); free_temp(t); longjmp(func_tag, TAG_RETURN); break; default: /* * Appears to be an expression statement. Throw away the * value. */ DBG_P(("E", (int)NULL)); t = tree_eval(tree); free_temp(t); break; } return 1;}/* evaluate a subtree, allocating strings on a temporary stack. */NODE *r_tree_eval(tree)NODE *tree;{ register NODE *r, *t1, *t2; /* return value & temporary subtrees */ int i; register NODE **lhs; int di; AWKNUM x, x2; long lx; extern NODE **fields_arr; source = tree->source_file; sourceline = tree->source_line; switch (tree->type) { case Node_and: DBG_P(("AND", (int)tree)); return tmp_number((AWKNUM) (eval_condition(tree->lnode) && eval_condition(tree->rnode))); case Node_or: DBG_P(("OR", (int)tree)); return tmp_number((AWKNUM) (eval_condition(tree->lnode) || eval_condition(tree->rnode))); case Node_not: DBG_P(("NOT", (int)tree)); return tmp_number((AWKNUM) ! eval_condition(tree->lnode)); /* Builtins */ case Node_builtin: DBG_P(("builtin", (int)tree)); return ((*tree->proc) (tree->subnode)); case Node_K_getline: DBG_P(("GETLINE", (int)tree)); return (do_getline(tree)); case Node_in_array: DBG_P(("IN_ARRAY", (int)tree)); return tmp_number((AWKNUM) in_array(tree->lnode, tree->rnode)); case Node_func_call: DBG_P(("func_call", (int)tree)); return func_call(tree->rnode, tree->lnode); case Node_K_delete: DBG_P(("DELETE", (int)tree)); do_delete(tree->lnode, tree->rnode); return Nnull_string; /* unary operations */ case Node_var: case Node_var_array: case Node_param_list: case Node_subscript: case Node_field_spec: DBG_P(("var_type ref", (int)tree)); lhs = get_lhs(tree, 0); field_num = -1; deref = 0; return *lhs; case Node_unary_minus: DBG_P(("UMINUS", (int)tree)); t1 = tree_eval(tree->subnode); x = -force_number(t1); free_temp(t1); return tmp_number(x); case Node_cond_exp: DBG_P(("?:", (int)tree)); if (eval_condition(tree->lnode)) { DBG_P(("True", (int)tree->rnode->lnode)); return tree_eval(tree->rnode->lnode); } DBG_P(("False", (int)tree->rnode->rnode)); return tree_eval(tree->rnode->rnode); case Node_match: case Node_nomatch: case Node_regex: DBG_P(("[no]match_op", (int)tree)); return match_op(tree); case Node_func: fatal("function `%s' called with space between name and (,\n%s", tree->lnode->param, "or used in other expression context"); /* assignments */ case Node_assign: DBG_P(("ASSIGN", (int)tree)); r = tree_eval(tree->rnode); lhs = get_lhs(tree->lnode, 1); *lhs = dupnode(r); free_temp(r); do_deref(); if (field_num == 0) set_record(fields_arr[0]->stptr, fields_arr[0]->stlen); field_num = -1; return *lhs; /* other assignment types are easier because they are numeric */ case Node_preincrement: case Node_predecrement: case Node_postincrement: case Node_postdecrement: case Node_assign_exp: case Node_assign_times: case Node_assign_quotient: case Node_assign_mod: case Node_assign_plus: case Node_assign_minus: return op_assign(tree); default: break; /* handled below */ } /* evaluate subtrees in order to do binary operation, then keep going */ t1 = tree_eval(tree->lnode); t2 = tree_eval(tree->rnode); switch (tree->type) { case Node_concat: DBG_P(("CONCAT", (int)tree)); t1 = force_string(t1); t2 = force_string(t2); r = newnode(Node_val); r->flags |= (STR|TEMP); r->stlen = t1->stlen + t2->stlen; r->stref = 1; emalloc(r->stptr, char *, r->stlen + 1, "tree_eval"); memcpy(r->stptr, t1->stptr,
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:gawk:gawk-2.11:eval.c
+++++ Continued from previous card +++++
t1->stlen); memcpy(r->stptr + t1->stlen, t2->stptr, t2->stlen + 1); free_temp(t1); free_temp(t2); re case Node_geq: case Node_leq: case Node_greater: case Node_less: case Node_notequal: case Node_equal: di = cmp_nodes(t1, t2); free_temp(t1); free_temp(t2); switch (tree->type) { case Node_equal: DBG_P(("EQUAL", (int)tree)); return tmp_number((AWKNUM) (di == 0)); case Node_notequal: DBG_P(("NOT_EQUAL", (int)tree)); return tmp_number((AWKNUM) (di != 0)); case Node_less: DBG_P(("LESS_THAN", (int)tree)); return tmp_number((AWKNUM) (di < 0)); case Node_greater: DBG_P(("GREATER_THAN", (int)tree)); return tmp_number((AWKNUM) (di > 0)); case Node_leq: DBG_P(("LESS_THAN_EQUAL", (int)tree)); return tmp_number((AWKNUM) (di <= 0)); case Node_geq: DBG_P(("GREATER_THAN_EQUAL", (int)tree)); return tmp_number((AWKNUM) (di >= 0)); default: cant_happen(); } break; default: break; /* handled below */ } (void) force_number(t1); (void) force_number(t2); switch (tree->type) { case Node_exp: DBG_P(("EXPONENT", (int)tree)); if ((lx = t2->numbr) == t2->numbr) { /* integer exponent */ if (lx == 0) x = 1; else if (lx == 1) x = t1->numbr; else { /* doing it this way should be more precise */ for (x = x2 = t1->numbr; --lx; ) x *= x2; } } else x = pow((double) t1->numbr, (double) t2->numbr); free_temp(t1); free_temp(t2); return tmp_number(x); case Node_times: DBG_P(("MULT", (int)tree)); x = t1->numbr * t2->numbr; free_temp(t1); free_temp(t2); return tmp_number(x); case Node_quotient: DBG_P(("DIVIDE", (int)tree)); x = t2->numbr; free_temp(t2); if (x == (AWKNUM) 0) fatal("division by zero attempted"); /* NOTREACHED */ else { x = t1->numbr / x; free_temp(t1); return tmp_number(x); } case Node_mod: DBG_P(("MODULUS", (int)tree)); x = t2->numbr; free_temp(t2); if (x == (AWKNUM) 0) fatal("division by zero attempted in mod"); /* NOTREACHED */ lx = t1->numbr / x; /* assignment to long truncates */ x2 = lx * x; x = t1->numbr - x2; free_temp(t1); return tmp_number(x); case Node_plus: DBG_P(("PLUS", (int)tree)); x = t1->numbr + t2->numbr; free_temp(t1); free_temp(t2); return tmp_number(x); case Node_minus: DBG_P(("MINUS", (int)tree)); x = t1->numbr - t2->numbr; free_temp(t1); free_temp(t2); return tmp_number(x); default: fatal("illegal type (%d) in tree_eval", tree->type); } return 0;}/* * This makes numeric operations slightly more efficient. Just change the * value of a numeric node, if possible */voidassign_number(ptr, value)NODE **ptr;AWKNUM value;{ extern NODE *deref; register NODE *n = *ptr;#ifdef DEBUG if (n->type != Node_val) cant_happen();#endif if (n == Nnull_string) { *ptr = make_number(value); deref = 0; return; } if (n->stref > 1) { *ptr = make_number(value); return; } if ((n->flags & STR) && (n->flags & (MALLOC|TEMP))) free(n->stptr); n->numbr = value; n->flags |= (NUM|NUMERIC); n->flags &= ~STR; n->stref = 0; deref = 0;}/* Is TREE true or false? Returns 0==false, non-zero==true */static inteval_condition(tree)NODE *tree;{ register NODE *t1; int ret; if (tree == NULL) /* Null trees are the easiest kinds */ return 1; if (tree->type == Node_line_range) { /* * Node_line_range is kind of like Node_match, EXCEPT: the * lnode field (more properly, the condpair field) is a node * of a Node_cond_pair; whether we evaluate the lnode of that * node or the rnode depends on the triggered word. More * precisely: if we are not yet triggered, we tree_eval the * lnode; if that returns true, we set the triggered word. * If we are triggered (not ELSE IF, note), we tree_eval the * rnode, clear triggered if it succeeds, and perform our * action (regardless of success or failure). We want to be * able to begin and end on a single input record, so this * isn't an ELSE IF, as noted above. */ if (!tree->triggered) if (!eval_condition(tree->condpair->lnode)) return 0; else tree->triggered = 1; /* Else we are triggered */ if (eval_condition(tree->condpair->rnode)) tree->triggered = 0; return 1; } /* * Could just be J.random expression. in which case, null and 0 are * false, anything else is true */ t1 = tree_eval(tree); if (t1->flags & NUMERIC) ret = t1->numbr != 0.0; else ret = t1->stlen != 0; free_temp(t1); return ret;}intcmp_nodes(t1, t2)NODE *t1, *t2;{ AWKNUM d; AWKNUM d1; AWKNUM d2; int ret; int len1, len2; if (t1 == t2) return 0; d1 = force_number(t1); d2 = force_number(t2); if ((t1->flags & NUMERIC) && (t2->flags & NUMERIC)) { d = d1 - d2; if (d == 0.0) /* from profiling, this is most common */ return 0; if (d > 0.0) return 1; return -1; } t1 = force_string(t1); t2 = force_string(t2); len1 = t1->stlen; len2 = t2->stlen; if (len1 == 0) { if (len2 == 0) return 0; else return -1; } else if (len2 == 0) return 1; ret = memcmp(t1->stptr, t2->stptr, len1 <= len2 ? len1 : len2); if (ret == 0 && len1 != len2) return len1 < len2 ? -1: 1; return ret;}static NODE *op_assign(tree)NODE *tree;{ AWKNUM rval, lval; NODE **lhs; AWKNUM t1, t2; long ltemp; NODE *tmp; lhs = get_lhs(tree->lnode, 1); lval = force_number(*lhs); switch(tree->type) { case Node_preincrement: case Node_predecrement: DBG_P(("+-X", (int)tree)); assign_number(lhs, lval + (tree->type == Node_preincrement ? 1.0 : -1.0)); do_deref(); if (field_num == 0) set_record(fields_arr[0]->stptr, fields_arr[0]->stlen); field_num = -1; return *lhs; case Node_postincrement: case Node_postdecrement: DBG_P(("X+-", (int)tree)); assign_number(lhs, lval + (tree->type == Node_postincrement ? 1.0 : -1.0)); do_deref(); if (field_num == 0) set_record(fields_arr[0]->stptr, fields_arr[0]->stlen); field_num = -1; return tmp_number(lval); default: break; /* handled below */ } tmp = tree_eval(tree->rnode); rval = force_number(tmp); free_temp(tmp); switch(tree->type) { case Node_assign_exp: DBG_P(("ASSIGN_exp", (int)tree)); if ((ltemp = rval) == rval) { /* integer exponent */ if (ltemp == 0) assign_number(lhs, (AWKNUM) 1); else if (ltemp == 1) assign_number(lhs, lval); else { /* doing it this way should be more precise */ for (t1 = t2 = lval; --ltemp; ) t1 *= t2; assign_number(lhs, t1); } } else assign_number(lhs, (AWKNUM) pow((double) lval, (double) rval)); break; case Node_assign_times: DBG_P(("ASSIGN_times", (int)tree)); assign_number(lhs, lval * rval); break; case Node_assign_quotient: DBG_P(("ASSIGN_quotient", (int)tree)); if (rval == (AWKNUM) 0) fatal("division by zero attempted in /="); assign_number(lhs, lval / rval); break; case Node_assign_mod: DBG_P(("ASSIGN_mod", (int)tree)); if (rval == (AWKNUM) 0) fatal("division by zero attempted in %="); ltemp = lval / rval; /* assignment to long truncates */ t1 = ltemp * rval; t2 = lval - t1; assign_number(lhs, t2); break; case Node_assign_plus: DBG_P(("ASSIGN_plus", (int)tree)); assign_number(lhs, lval + rval); break; case Node_assign_minus: DBG_P(("ASSIGN_minus", (int)tree)); assign_number(lhs, lval - rval); break; default: cant_happen(); } do_deref(); if (field_num == 0) set_record(fields_arr[0]->stptr, fields_arr[0]->stlen); field_num = -1; return *lhs;}NODE **stack_ptr;static NODE *func_call(name, arg_list)NODE *name; /* name is a Node_val giving function name */NODE *arg_list; /* Node_expression_list of calling args. */{ register NODE *arg, *argp, *r; NODE *n, *f; volatile jmp_buf func_tag_stack; volatile jmp_buf loop_tag_stack; volatile int save_loop_tag_valid = 0; volatile NODE **save_stack, *save_ret_node; NODE **local_stack, **sp; int count; extern NODE *ret_node; /* * retrieve function definition node */ f = lookup(variables, name->stptr); if (!f || f->type != Node_func) fatal("function `%s' not defined", name->stptr);#ifdef FUNC_TRACE fprintf(stderr, "function %s called\n", name->stptr);#endif count = f->lnode->param_cnt; emalloc(local_stack, NODE **, count * sizeof(NODE *), "func_call"); sp = local_stack; /* * for each calling arg. add NODE * on stack */ for (argp = arg_list; count && argp != NULL; argp = argp->rnode) { arg = argp->lnode; r = newnode(Node_var); /* * call by reference for arrays; see below also */ if (arg->type == Node_param_list) arg = stack_ptr[arg->param_cnt]; if (arg->type == Node_var_array) *r = *arg; else { n = tree_eval(arg); r->lnode = dupnode(n); r->rnode = (NODE *) NULL; free_temp(n); } *sp++ = r; count--; } if (argp != NULL) /* left over calling args. */ warning( "function `%s' called with more arguments than declared", name->stptr); /* * add remaining params. on stack with null value */ while (count-- > 0) { r = newnode(Node_var); r->lnode = Nnull_string; r->rnode = (NODE *) NULL; *sp++ = r; } /* * Execute function body, saving context, as a return statement * will longjmp back here. * * Have to save and restore the loop_tag stuff so that a return * inside a loop in a function body doesn't scrog any loops going * on in the main program. We save the necessary info in variables * local to this function so that function nesting works OK. * We also only bother to save the loop stuff if we're in a loop * when the function is called. */ if (loop_tag_valid) { int junk = 0; save_loop_tag_valid = (volatile int) loop_tag_valid; PUSH_BINDING(loop_tag_stack, loop_tag, junk); loop_tag_valid = 0; } save_stack = (volatile NODE **) stack_ptr; stack_ptr = local_stack; PUSH_BINDING(func_tag_stack, func_tag, func_tag_valid); save_ret_node = (volatile NODE *) ret_node; ret_node = Nnull_string; /* default return value */ if (setjmp(func_tag) == 0) (void) interpret(f->rnode); r = ret_node; ret_node = (NODE *) save_ret_node; RESTORE_BINDING(func_tag_stack, func_tag, func_tag_valid); stack_ptr = (NODE **) save_stack; /* * here, we pop each parameter and check whether * it was an array. If so, and if the arg. passed in was * a simple variable, then the value should be copied back. * This achieves "call-by-reference" for arrays. */ sp = local_stack; count = f->lnode->param_cnt; for (argp = arg_list; count > 0 && argp != NULL; argp = argp->rnode) { arg = argp->lnode; n = *sp++; if (arg->type == Node_var && n->type == Node_var_array) { arg->var_array = n->var_array; arg->type = Node_var_array; } deref = n->lnode; do_deref(); freenode(n); count--; } while (count-- > 0) { n = *sp++; deref = n->lnode; do_deref(); freenode(n); } free((char *) local_stack); /* Restore the loop_tag stuff if necessary. */ if (save_loop_tag_valid) { int junk = 0; loop_tag_valid = (int) save_loop_tag_valid; RESTORE_BINDING(loop_tag_stack, loop_tag, junk); } if (!(r->flags & PERM)) r->flags |= TEMP; return r;}/* * This returns a POINTER to a node pointer. get_lhs(ptr) is the current * value of the var, or where to store the var's new value */NODE **get_lhs(ptr, assign)NODE *ptr;int assign; /* this is being called for the LHS of an assign. */{ register NODE **aptr; NODE *n;#ifdef DEBUG if (ptr == NULL) cant_happen();#endif deref = NULL; field_num = -1; switch (ptr->type) { case Node_var: case Node_var_array: if (ptr == NF_node && (int) NF_node->var_value->numbr == -1) (void) get_field(HUGE-1, assign); /* parse record */ deref = ptr->var_value;#ifdef DEBUG if (deref->type != Node_val) cant_happen(); if (deref->flags == 0) cant_happen();#endif return &(ptr->var_value); case Node_param_list: n = stack_ptr[ptr->param_cnt]; deref = n->var_value;#ifdef DEBUG if (deref->type != Node_val) cant_happen(); if (deref->flags == 0) cant_happen();#endif return &(n->var_value); case Node_field_spec: n = tree_eval(ptr->lnode); field_num = (int) force_number(n); free_temp(n); if (field_num < 0) fatal("attempt to access field %d", field_num); aptr = get_field(field_num, assign); deref = *aptr; return aptr; case Node_subscript: n = ptr->lnode; if (n->type == Node_param_list) n = stack_ptr[n->param_cnt]; aptr = assoc_lookup(n, concat_exp(ptr->rnode)); deref = *aptr;#ifdef DEBUG if (deref->type != Node_val) cant_happen(); if (deref->flags == 0) cant_happen();#endif return aptr; case Node_func: fatal ("`%s' is a function, assignment is not allowed", ptr->lnode->param); default: cant_happen(); } return 0;}static NODE *match_op(tree)NODE *tree;{ NODE *t1; struct re_pattern_buffer *rp; int i; int match = 1; if (tree->type == Node_nomatch) match = 0; if (tree->type == Node_regex) t1 = WHOLELINE; else { if (tree->lnode) t1 = force_string(tree_eval(tree->lnode)); else t1 = WHOLELINE; tree = tree->rnode; } if (tree->type == Node_regex) { rp = tree->rereg; if (!strict && ((IGNORECASE_node->var_value->numbr != 0) ^ (tree->re_case != 0))) { /* recompile since case sensitivity differs */ rp = tree->rereg = mk_re_parse(tree->re_text, (IGNORECASE_node->var_value->numbr != 0)); tree->re_case = (IGNORECASE_node->var_value->numbr != 0); } } else { rp = make_regexp(force_string(tree_eval(tree)), (IGNORECASE_node->var_value->numbr != 0)); if (rp == NULL) cant_happen(); } i = re_search(rp, t1->stptr, t1->stlen, 0, t1->stlen, (struct re_registers *) NULL); i = (i == -1) ^ (match == 1); free_temp(t1); if (tree->type != Node_regex) { free(rp->buffer); free(rp->fastmap); free((char *) rp); } return tmp_number((AWKNUM) i);} :MPW:MPW Tools:Tools with Source:gawk:gawk-2.11:field.c
/* * field.c - routines for dealing with fields and record parsing *//* * Copyright (C) 1986, 1988, 1989 the Free Software Foundation, Inc. * * This file is part of GAWK, the GNU implementation of the * AWK Progamming Language. * * GAWK is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 1, or (at your option) * any later version. * * GAWK is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with GAWK; see the file COPYING. If not, write to * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */#include "awk.h"extern void assoc_clear();extern int a_get_three();extern int get_rs();static char *get_fs();static int re_split();static int parse_fields();static void set_element();char *line_buf = NULL; /* holds current input line */static char *parse_extent; /* marks where to restart parse of record */static int parse_high_water=0; /* field number that we have parsed so far */static char f_empty[] = "";static char *save_fs = " "; /* save current value of FS when line is read, * to be used in deferred parsing */NODE **fields_arr; /* array of pointers to the field nodes */NODE node0; /* node for $0 which never gets free'd */int node0_valid = 1; /* $(>0) has not been changed yet */voidinit_fields(){ emalloc(fields_arr, NODE **, sizeof(NODE *), "init_fields"); node0.type = Node_val; node0.stref = 0; node0.stptr = ""; node0.flags = (STR|PERM); /* never free buf */ fields_arr[0] = &node0;}/* * Danger! Must only be called for fields we know have just been blanked, or * fields we know don't exist yet. *//*ARGSUSED*/static voidset_field(num, str, len, dummy)int num;char *str;int len;NODE *dummy; /* not used -- just to make interface same as set_element */{ NODE *n; int t; static int nf_high_water = 0; if (num > nf_high_water) { erealloc(fields_arr, NODE **, (num + 1) * sizeof(NODE *), "set_field"); nf_high_water = num; } /* fill in fields that don't exist */ for (t = parse_high_water + 1; t < num; t++) fields_arr[t] = Nnull_string; n = make_string(str, len); (void) force_number(n); fields_arr[num] = n; parse_high_water = num;}/* Someone assigned a value to $(something). Fix up $0 to be right */static voidrebuild_record(){ register int tlen; register NODE *tmp; NODE *ofs; char *ops; register char *cops; register NODE **ptr; register int ofslen; tlen = 0; ofs = force_string(OFS_node->var_value); ofslen = ofs->stlen; ptr = &fields_arr[parse_high_water]; while (ptr > &fields_arr[0]) { tmp = force_string(*ptr); tlen += tmp->stlen; ptr--; } tlen += (parse_high_water - 1) * ofslen; emalloc(ops, char *, tlen + 1, "fix_fields"); cops = ops; ops[0] = '\0'; for (ptr = &fields_arr[1]; ptr <= &fields_arr[parse_high_water]; ptr++) { tmp = *ptr; if (tmp->stlen == 1) *cops++ = tmp->stptr[0]; else if (tmp->stlen != 0) { memcpy(cops, tmp->stptr, tmp->stlen); cops += tmp->stlen; } if (ptr != &fields_arr[parse_high_water]) { if (ofslen == 1) *cops++ = ofs->stptr[0]; else if (ofslen != 0) { memcpy(cops, ofs->stptr, ofslen); cops += ofslen; } } } tmp = make_string(ops, tlen); free(ops); deref = fields_arr[0]; do_deref(); fields_arr[0] = tmp;}/* * setup $0, but defer parsing rest of line until reference is made to $(>0) * or to NF. At that point, parse only as much as necessary. */voidset_record(buf, cnt)char *buf;int cnt;{ register int i; assign_number(&NF_node->var_value, (AWKNUM)-1); for (i = 1; i <= parse_high_water; i++) { deref = fields_arr[i]; do_deref(); } parse_high_water = 0; node0_valid = 1; if (buf == line_buf) { deref = fields_arr[0]; do_deref(); save_fs = get_fs(); node0.type = Node_val; node0.stptr = buf; node0.stlen = cnt; node0.stref = 1; node0.flags = (STR|PERM); /* never free buf */ fields_arr[0] = &node0; }}NODE **get_field(num, assign)int num;int assign; /* this field is on the LHS of an assign */{ int n; /* * if requesting whole line but some other field has been altered, * then the whole line must be rebuilt */ if (num == 0 && (node0_valid == 0 || assign)) { /* first, parse remainder of input record */ if (NF_node->var_value->numbr == -1) { if (parse_high_water == 0) parse_extent = node0.stptr; n = parse_fields(HUGE-1, &parse_extent, node0.stlen - (parse_extent - node0.stptr), save_fs, set_field, (NODE *)NULL); assign_number(&NF_node->var_value, (AWKNUM)n); } if (node0_valid == 0) rebuild_record(); return &fields_arr[0]; } if (num > 0 && assign) node0_valid = 0; if (num <= parse_high_water) /* we have already parsed this field */ return &fields_arr[num]; if (parse_high_water == 0 && num > 0) /* starting at the beginning */ parse_extent = fields_arr[0]->stptr; /* * parse up to num fields, calling set_field() for each, and saving * in parse_extent the point where the parse left off */ n = parse_fields(num, &parse_extent, fields_arr[0]->stlen - (parse_extent-fields_arr[0]->stptr), save_fs, set_field, (NODE *)NULL); if (num == HUGE-1) num = n; if (n < num) { /* requested field number beyond end of record; * set_field will just extend the number of fields, * with empty fields */ set_field(num, f_empty, 0, (NODE *) NULL); /* * if this field is onthe LHS of an assignment, then we want to * set NF to this value, below */ if (assign) n = num; } /* * if we reached the end of the record, set NF to the number of fields * so far. Note that num might actually refer to a field that * is beyond the end of the record, but we won't set NF to that value at * this point, since this is only a reference to the field and NF * only gets set if the field is assigned to -- in this case n has * been set to num above */ if (*parse_extent == '\0') assign_number(&NF_node->var_value, (AWKNUM)n); return &fields_arr[num];}/* * this is called both from get_field() and from do_split() */static intparse_fields(up_to, buf, len, fs, set, n)int up_to; /* parse only up to this field number */char **buf; /* on input: string to parse; on output: point to start next */int len;register char *fs;void (*set) (); /* routine to set the value of the parsed field */NODE *n;{ char *s = *buf; register char *field; register char *scan; register char *end = s + len; int NF = parse_high_water; char rs = get_rs(); if (up_to == HUGE) NF = 0; if (*fs && *(fs + 1) != '\0') { /* fs is a regexp */ struct re_registers reregs; scan = s; if (rs == 0 && STREQ(FS_node->var_value->stptr, " ")) { while ((*scan == '\n' || *scan == ' ' || *scan == '\t') && scan < end) scan++; } s = scan; while (scan < end && re_split(scan, (int)(end - scan), fs, &reregs) != -1 && NF < up_to) { if (reregs.end[0] == 0) { /* null match */ scan++; if (scan == end) { (*set)(++NF, s, scan - s, n); up_to = NF; break; } continue; } (*set)(++NF, s, scan - s + reregs.start[0], n); scan += reregs.end[0]; s = scan; } if (NF != up_to && scan <= end) { if (!(rs == 0 && scan == end)) { (*set)(++NF, scan, (int)(end - scan), n); scan = end; } } *buf = scan; return (NF); } for (scan = s; scan < end && NF < up_to; scan++) { /* * special case: fs is single space, strip leading * whitespace */ if (*fs == ' ') { while ((*scan == ' ' || *scan == '\t') && scan < end) scan++; if (scan >= end) break; } field = scan; if (*fs == ' ') while (*scan != ' ' && *scan != '\t' && scan < end) scan++; else { while (*scan != *fs && scan < end) scan++; if (rs && scan == end-1 && *scan == *fs) { (*set)(++NF, field, (int)(scan - field), n); field = scan; } } (*set)(++NF, field, (int)(scan - field), n); if (scan == end) break; } *buf = scan; return NF;}static intre_split(buf, len, fs, reregsp)char *buf, *fs;int len;struct re_registers *reregsp;{ typedef struct re_pattern_buffer RPAT; static RPAT *rp; static char *last_fs = NULL; if ((last_fs != NULL && !STREQ(fs, last_fs)) || (rp && ! strict && ((IGNORECASE_node->var_value->numbr != 0) ^ (rp->translate != NULL)))) { /* fs has changed or IGNORECASE has changed */ free(rp->buffer); free(rp->fastmap); free((char *) rp); free(last_fs); last_fs = NULL; } if (last_fs == NULL) { /* first time */ emalloc(rp, RPAT *, sizeof(RPAT), "re_split"); memset((char *) rp, 0, sizeof(RPAT)); emalloc(rp->buffer, char *, 8, "re_split"); rp->allocated = 8; emalloc(rp->fastmap, char *, 256, "re_split"); emalloc(last_fs, char *, strlen(fs) + 1, "re_split"); (void) strcpy(last_fs, fs); if (! strict && IGNORECASE_node->var_value->numbr != 0.0) rp->translate = casetable; else rp->translate = NULL; if (re_compile_pattern(fs, strlen(fs), rp) != NULL) fatal("illegal regular expression for FS: `%s'", fs); } return re_search(rp, buf, len, 0, len, reregsp);}NODE *do_split(tree)NODE *tree;{ NODE *t1, *t2, *t3; register char *splitc; char *s; NODE *n; if (a_get_three(tree, &t1, &t2, &t3) < 3) splitc = get_fs(); else splitc = force_string(t3)->stptr; n = t2; if (t2->type == Node_param_list) n = stack_ptr[t2->param_cnt]; if (n->type != Node_var && n->type != Node_var_array) fatal("second argument of split is not a variable"); assoc_clear(n); tree = force_string(t1); s = tree->stptr; return tmp_number((AWKNUM) parse_fields(HUGE, &s, tree->stlen, splitc, set_element, n));}static char *get_fs(){ register NODE *tmp; static char buf[10]; tmp = force_string(FS_node->var_value); if (get_rs() == 0) { if (tmp->stlen == 1) { if (tmp->stptr[0] == ' ') (void) strcpy(buf, "[ \n]+"); else sprintf(buf, "[%c\n]", tmp->stptr[0]); } else if (tmp->stlen == 0) { buf[0] = '\n'; buf[1] = '\0'; } else return tmp->stptr; return buf; } return tmp->stptr;}static voidset_element(num, s, len, n)int num;char *s;int len;NODE *n;{ *assoc_lookup(n, tmp_number((AWKNUM) (num))) = make_string(s, len);} :MPW:MPW Tools:Tools with Source:gawk:gawk-2.11:gnufuncts.c
/* * Copyright (C) 1986, 1988, 1989 the Free Software Foundation, Inc. * * This file is part of GAWK, the GNU implementation of the * AWK Progamming Language. * * GAWK is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 1, or (at your option) * any later version. * * GAWK is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with GAWK; see the file COPYING. If not, write to * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #include <stdio.h>#include <stdlib.h>#include <string.h>#include <math.h>#include "awk.h"void *memcpy();void bzero(p,n)void *p;int n;{ memset(p,'\0',n);}FILE *popen(s,mode)char *s,*mode;{ fprintf(stderr,"Sorry, pipes are not implemented.\n"); exit(20);}pclose(fp)FILE *fp;{ fprintf(stderr, "Sorry, pipes are not implemented.\n"); exit(21);}int bcmp(d,d2,mcnt)char *d,*d2;int mcnt;{ if (strncmp(d,d2,mcnt)) return(1); else return(0);} char *index(s, c)char *s,c;{ return (strchr(s,c));}int pipe(fildes)int fildes[2];{ fprintf(stderr,"Sorry, pipes are not implemented.\n"); exit(22);}int fork(){ fprintf(stderr,"Sorry, can't fork.\n"); exit(23); }int wait(junk)void * junk;{ fprintf(stderr,"Sorry, can't wait.\n"); exit(24);}intdup2 (old, new)int old, new;{ fprintf(stderr,"Sorry, no dup2.\n"); exit(25);}pointer xmalloc(n)unsigned int n;{ extern pointer malloc(); pointer cp; static char mesg[] = "xmalloc: no memory!\n"; cp = malloc(n); if (! cp) { write (2, mesg, sizeof(mesg) - 1); exit(1); } return cp;} :MPW:MPW Tools:Tools with Source:gawk:gawk-2.11:io.c
/* * io.c - routines for dealing with input and output and records *//* * Copyright (C) 1986, 1988, 1989 the Free Software Foundation, Inc. * * This file is part of GAWK, the GNU implementation of the * AWK Progamming Language. * * GAWK is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 1, or (at your option) * any later version. * * GAWK is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with GAWK; see the file COPYING. If not, write to * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */#include "awk.h"#ifndef O_RDONLY#include <fcntl.h>#endif#include <signal.h>extern FILE *popen();static void do_file();static IOBUF *nextfile();static int get_a_record();static int iop_close();static IOBUF *iop_alloc();static void close_one();static int close_redir();static IOBUF *gawk_popen();static int gawk_pclose();static struct redirect *red_head = NULL;static int getline_redirect = 0; /* "getline <file" being executed */extern char *line_buf;extern int output_is_tty;extern NODE *ARGC_node;extern NODE *ARGV_node;extern NODE **fields_arr;int field_num;static IOBUF *nextfile(){ static int i = 1; static int files = 0; static IOBUF *curfile = NULL; char *arg; char *cp; int fd = -1; if (curfile != NULL && curfile->cnt != EOF) return curfile; for (; i < (int) (ARGC_node->lnode->numbr); i++) { arg = (*assoc_lookup(ARGV_node, tmp_number((AWKNUM) i)))->stptr; if (*arg == '\0') continue; cp = strchr(arg, '='); if (cp != NULL) { *cp++ = '\0'; variable(arg)->var_value = make_string(cp, strlen(cp)); *--cp = '='; /* restore original text of ARGV */ } else { files++; if (STREQ(arg, "-")) fd = 0; else fd = devopen(arg, "r"); if (fd == -1) fatal("cannot open file `%s' for reading (%s)", arg, strerror(errno)); /* NOTREACHED */ /* This is a kludge. */ deref = FILENAME_node->var_value; do_deref(); FILENAME_node->var_value = make_string(arg, strlen(arg)); FNR_node->var_value->numbr = 0.0; i++; break; } } if (files == 0) { files++; /* no args. -- use stdin */ /* FILENAME is init'ed to "-" */ /* FNR is init'ed to 0 */ fd = 0; } if (fd == -1) return NULL; return curfile = iop_alloc(fd);}static IOBUF *iop_alloc(fd)int fd;{ IOBUF *fndef THINK_C struct stat stb; /* * System V doesn't have the file system block size in the * stat structure. So we have to make some sort of reasonable * guess. We use stdio's BUFSIZ, since that is what it was * meant for in the first place. */#ifdef BLKSIZE_MISSING#define DEFBLKSIZE BUFSIZ#else#define DEFBLKSIZE (stb.st_blksize ? stb.st_blksize : BUFSIZ)#endif#endif#ifdef THINK_C#define DEFBLKSIZE BUFSIZ if (fd == -1) return NULL; emalloc(iop, IOBUF *, sizeof(IOBUF), "nextfile"); iop->flag = 0; if (isatty(fd)) { iop->flag |= IOP_IS_TTY; iop->size = BUFSIZ; } #ifndef THINK_C else if (fstat(fd, &stb) == -1) fatal("can't stat fd %d (%s)", fd, strerror(errno)); else if (lseek(fd, 0L, 0) == -1) iop->size = DEFBLKSIZE; else iop->size = (stb.st_size < DEFBLKSIZE ? stb.st_size+1 : DEFBLKSIZE);#else iop->size = DEFBLKSIZE;#endif errno = 0; iop->fd = fd; emalloc(iop->buf, char *, iop->size, "nextfile"); iop->off = iop->buf; iop->cnt = 0; iop->secsiz = iop->size < BUFSIZ ? iop->size : BUFSIZ; emalloc(iop->secbuf, char *, iop->secsiz, "nextfile"); return iop;}voiddo_input(){ IOBUF *iop; extern int exiting; while ((iop = nextfile()) != NULL) { do_file(iop); if (exiting) break; }}static intiop_close(iop)IOBUF *iop;{ int ret; ret = close(iop->fd); if (ret == -1) warning("close of fd %d failed (%s)", iop->fd, strerror(errno)); free(iop->buf); free(iop->secbuf); free((char *)iop); return ret == -1 ? 1 : 0;}/* * This reads in a record from the input file */static intinrec(iop)IOBUF *iop;{ int cnt; int retval = 0; cnt = get_a_record(&line_buf, iop); if (cnt == EOF) { cnt = 0; retval = 1; } else { if (!getline_redirect) { assign_number(&NR_node->var_value, NR_node->var_value->numbr + 1.0); assign_number(&FNR_node->var_value, FNR_node->var_value->numbr + 1.0); } } set_record(line_buf, cnt); return retval;}static voiddo_file(iop)IOBUF *iop;{ /* This is where it spends all its time. The infamous MAIN LOOP */ if (inrec(iop) == 0) while (interpret(expression_value) && inrec(iop) == 0) ; (void) iop_close(iop);}intget_rs(){ register NODE *tmp; tmp = force_string(RS_node->var_value); if (tmp->stlen == 0) return 0; return *(tmp->stptr);}/* Redirection for printf and print commands */struct redirect *redirect(tree, errflg)NODE *tree;int *errflg;{ register NODE *tmp; register struct redirect *rp; register char *str; int tflag = 0; int outflag = 0; char *direction = "to"; char *mode; int fd; switch (tree->type) { case Node_redirect_append: tflag = RED_APPEND; case Node_redirect_output: outflag = (RED_FILE|RED_WRITE); tflag |= outflag; break; case Node_redirect_pipe: tflag = (RED_PIPE|RED_WRITE); break; case Node_redirect_pipein: tflag = (RED_PIPE|RED_READ); break; case Node_redirect_input: tflag = (RED_FILE|RED_READ); break; default: fatal ("invalid tree type %d in redirect()", tree->type); break; } tmp = force_string(tree_eval(tree->subnode)); str = tmp->stptr; for (rp = red_head; rp != NULL; rp = rp->next) if (STREQ(rp->value, str) && ((rp->flag & ~RED_NOBUF) == tflag || (outflag && (rp->flag & (RED_FILE|RED_WRITE)) == outflag))) break; if (rp == NULL) { emalloc(rp, struect *, sizeof(struct redirect), "redirect"); emalloc(str, char *, tmp->stlen+1, "redirect"); memcpy(str, tmp->stptr, tmp->stlen+1); rp->value = str; rp->flag = tflag; rp->offset = 0; rp->fp = NULL; rp->iop = NULL; /* maintain list in most-recently-used first order */ if (red_head) red_head->prev = rp; rp->prev = NULL; rp->next = red_head; red_head = rp; } while (rp->fp == NULL && rp->iop == NULL) { mode = NULL; errno = 0; switch (tree->type) { case Node_redirect_output: mode = "w"; break; case Node_redirect_append: mode = "a"; break; case Node_redirect_pipe: if ((rp->fp = popen(str, "w")) == NULL) fatal("can't open pipe (\"%s\") for output (%s)", str, strerror(errno)); rp->flag |= RED_NOBUF; break; case Node_redirect_pipein: direction = "from"; if (gawk_popen(str, rp) == NULL) fatal("can't open pipe (\"%s\") for input (%s)", str, strerror(errno)); break; case Node_redirect_input: direction = "from"; rp->iop = iop_alloc(devopen(str, "r")); break; default: cant_happen(); } if (mode != NULL) { fd = devopen(str, mode); if (fd != -1) { rp->fp = fdopen(fd, mode); if (isatty(fd)) rp->flag |= RED_NOBUF; } } if (rp->fp == NULL && rp->iop == NULL) { /* too many files open -- close one and try again */ if (errno == ENFILE || errno == EMFILE) close_one(); else { /* * Some other reason for failure. * * On redirection of input from a file, * just return an error, so e.g. getline * can return -1. For output to file, * complain. The shell will complain on * a bad command to a pipe. */ *errflg = 1; if (tree->type == Node_redirect_output || tree->type == Node_redirect_append) fatal("can't redirect %s `%s' (%s)", direction, str, strerror(errno)); else return NULL; } } } if (rp->offset != 0) /* this file was previously open */ if (fseek(rp->fp, rp->offset, 0) == -1) fatal("can't seek to %ld on `%s' (%s)", rp->offset, str, strerror(errno)); free_temp(tmp); return rp;}static voidclose_one(){ register struct redirect *rp; register struct redirect *rplast = NULL; /* go to end of list first, to pick up least recently used entry */ for (rp = red_head; rp != NULL; rp = rp->next) rplast = rp; /* now work back up through the list */ for (rp = rplast; rp != NULL; rp = rp->prev) if (rp->fp && (rp->flag & RED_FILE)) { rp->offset = ftell(rp->fp); if (fclose(rp->fp)) warning("close of \"%s\" failed (%s).", rp->value, strerror(errno)); rp->fp = NULL; break; } if (rp == NULL) /* surely this is the only reason ??? */ fatal("too many pipes or input files open"); }NODE *do_close(tree)NODE *tree;{ NODE *tmp; register struct redirect *rp; tmp = force_string(tree_eval(tree->subnode)); for (rp = red_head; rp != NULL; rp = rp->next) { if (STREQ(rp->value, tmp->stptr)) break; } free_temp(tmp); if (rp == NULL) /* no match */ return tmp_number((AWKNUM) 0.0); fflush(stdout); /* synchronize regular output */ return tmp_number((AWKNUM)close_redir(rp));}static intclose_redir(rp)register struct redirect *rp;{ int status = 0; if ((rp->flag & (RED_PIPE|RED_WRITE)) == (RED_PIPE|RED_WRITE)) status = pclose(rp->fp); else if (rp->fp) status = fclose(rp->fp); else if (rp->iop) { if (rp->flag & RED_PIPE) status = gawk_pclose(rp); else status = iop_close(rp->iop); } /* SVR4 awk checks and warns about status of close */ if (status) warning("failure status (%d) on %s close of \"%s\" (%s).", status, (rp->flag & RED_PIPE) ? "pipe" : "file", rp->value, strerror(errno)); if (rp->next) rp->next->prev = rp->prev; if (rp->prev) rp->prev->next = rp->next; else red_head = rp->next; free(rp->value); free((char *)rp); return status;}intflush_io (){ register struct redirect *rp; int status = 0; errno = 0; if (fflush(stdout)) { warning("error writing standard output (%s).", strerror(errno)); status++; } errno = 0; if (fflush(stderr)) { warning("error writing standard error (%s).", strerror(errno)); status++; } for (rp = red_head; rp != NULL; rp = rp->next) /* flush both files and pipes, what the heck */ if ((rp->flag & RED_WRITE) && rp->fp != NULL) if (fflush(rp->fp)) { warning("%s flush of \"%s\" failed (%s).", (rp->flag & RED_PIPE) ? "pipe" : "file", rp->value, strerror(errno)); status++; } return status;}intclose_io (){ register struct redirect *rp; int status = 0; for (rp = red_head; rp != NULL; rp = rp->next) if (close_redir(rp)) status++; return status;}/* devopen --- handle /dev/std{in,out,err}, /dev/fd/N, regular files */intdevopen (name, mode)char *name, *mode;{ int openfd = -1; FILE *fdopen (); char *cp; int flag = 0; switch(mode[0]) { case 'r': flag = O_RDONLY; break; case 'w': flag = O_WRONLY|O_CREAT|O_TRUNC; break; case 'a': flag = O_WRONLY|O_APPEND|O_CREAT; break; default: cant_happen(); }#if defined(STRICT) || defined(NO_DEV_FD) return (open (name, flag, 0666));#else if (strict)#ifndef THINK_C return (open (name, flag, 0666));#else return (open (name, flag));#endif if (!STREQN (name, "/dev/", 5))#ifndef THINK_C return (open (name, flag, 0666));#else return(open (name, flag));#endif else cp = name + 5; /* XXX - first three tests ignore mode */ if (STREQ(cp, "stdin")) return (0); else if (STREQ(cp, "stdout")) return (1); else if (STREQ(cp, "stderr")) return (2); else if (STREQN(cp, "fd/", 3)) { cp += 3; if (sscanf (cp, "%d", & openfd) == 1 && openfd >= 0) /* got something */ return openfd; else return -1; } else#ifndef THINK_C return (open (name, flag, 0666));#else return (open (name, flag));#endif#endif}#ifndef MSDOSstatic IOBUF *gawk_popen(cmd, rp)char *cmd;struct redirect *rp;{ int p[2]; register int pid; rp->pid = -1; rp->iop = NULL; if (pipe(p) < 0) return NULL; if ((pid = fork()) == 0) { close(p[0]); dup2(p[1], 1); close(p[1]); execl("/bin/sh", "sh", "-c", cmd, 0); _exit(127); } if (pid == -1) return NULL; rp->pid = pid; close(p[1]); return (rp->iop = iop_alloc(p[0]));}static intgawk_pclose(rp)struct redirect *rp;{ SIGTYPE (*hstat)(), (*istat)(), (*qstat)(); int pid; int status; struct redirect *redp; iop_close(rp->iop); if (rp->pid == -1) return rp->status; istat = signal(SIGINT, SIG_IGN);#ifndef THINK_C hstat = signal(SIGHUP, SIG_IGN); qstat = signal(SIGQUIT, SIG_IGN);#else hstat = signal(SIGABRT, SIG_IGN); qstat = signal(SIGTERM, SIG_IGN);#endif for (;;) { pid = wait(&status);#ifndef THINK_C if (pid == -1 && errno == ECHILD)#else if (pid == -1)#endif break; else if (pid == rp->pid) { rp->pid = -1; rp->status = status; break; } else { for (redp = red_head; redp != NULL; redp = redp->next) if (pid == redp->pid) { redp->pid = -1; redp->status = status; break; } } } signal(SIGINT, istat);#ifndef THINK_C signal(SIGHUP, hstat); signal(SIGQUIT, qstat);#else signal(SIGABRT, hstat); signal(SIGTERM, qstat);#endif return(rp->status);}#elsestaticstruct { char *command; char *name;} pipes[_NFILE];static IOBUF *gawk_popen(cmd, rp)char *cmd;struct redirect *rp;{ extern char *strdup(const char *); int current; char *name; static char cmdbuf[256]; /* get a name to use. */ if ((name = tempnam(".", "pip")) == NULL) return NULL; sprintf(cmdbuf,"%s > %s", cmd, name); system(cmdbuf); if ((current = open(name,O_RDONLY)) == -1) return NULL; pipes[current].name = name; pipes[current].command = strdup(cmd); return (rp->iop = iop_alloc(current));}static intgawk_pclose(rp)struct redirect *rp;{ int cur = rp->iop->fd; int rval; rval = iop_close(rp->iop); /* check for an open file */ if (pipes[cur].name == NULL) return -1; unlink(pipes[cur].name); free(pipes[cur].name); pipes[cur].name = NULL; free(pipes[cur].command); return rval;}#endif#endif#define DO_END_OF_BUF len = bp - iop->off;\ used = last - start;\ while (len + used > iop->secsiz) {\ iop->secsiz *= 2;\ erealloc(iop->secbuf,char *,iop->secsiz,"get");\ }\ last = iop->secbuf + used;\ start = iop->secbuf;\ memcpy(last, iop->off, len);\ last += len;\ iop->cnt = read(iop->fd, iop->buf, iop->size);\ if (iop->cnt < 0)\ return iop->cnt;\ end_data = iop->buf + iop->cnt;\ iop->off = bp = iop->buf;#define DO_END_OF_DATA iop->cnt = read(iop->fd, end_data, end_buf - end_data);\ if (iop->cnt < 0)\ return iop->cnt;\ end_data += iop->cnt;\ if (iop->cnt == 0)\ break;\ iop->cnt = end_data - iop->buf;static intget_a_record(res, iop)char **res;IOBUF *iop;{ register char *end_data; register char *end_buf; char *start; register char *bp; register char *last; int len, used; register char rs = get_rs(); if (iop->cnt < 0) return iop->cnt; if ((iop->flag & IOP_IS_TTY) && output_is_tty) fflush(stdout); end_data = iop->buf + iop->cnt; if (iop->off >= end_data) { iop->cnt = read(iop->fd, iop->buf, iop->size); if (iop->cnt <= 0) return iop->cnt = EOF; end_data = iop->buf + iop->cnt; iop->off = iop->buf; } last = start = bp = iop->off; end_buf = iop->buf + iop->size; if (rs == 0) { while (!(*bp == '\n' && bp != iop->buf && bp[-1] == '\n')) { if (++bp == end_buf) { DO_END_OF_BUF } if (bp == end_data) { DO_END_OF_DATA } } if (*bp == '\n' && bp != iop->off && bp[-1] == '\n') { int tmp = 0; /* allow for more than two newlines */ while (*bp == '\n') { tmp++; if (++bp == end_buf) { DO_END_OF_BUF } if (bp == end_data) { DO_END_OF_DATA } } iop->off = bp; bp -= 1 + tmp; }
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:gawk:gawk-2.11:io.c
+++++ Continued from previous card +++++
else if (bp != iop->buf && bp[-1] != '\n') { warning("record not terminated"); iop->off = bp + 2; } else { bp--; iop->off = bp + 2; } } else { while (*bp++ != rs) { if (bp == end_buf) { DO_END_OF_BUF } if (bp == end_data) { DO_END_OF_DATA } } if (*--bp != rs) { warning("record not terminated"); bp++; } iop->off = bp + 1; } if (start == iop->secbuf) { len = bp - iop->buf; if (len > 0) { used = last - start; while (len + used > iop->secsiz) { iop->secsiz *= 2; erealloc(iop->secbuf,char *,iop->secsiz,"get2"); } last = iop->secbuf + used; start = iop->secbuf; memcpy(last, iop->buf, len); last += len; } } else last = bp; *last = '\0'; *res = start; return last - start;}NODE *do_getline(tree)NODE *tree;{ struct redirect *rp; IOBUF *iop; int cnt; NODE **lhs; int redir_error = 0; if (tree->rnode == NULL) { /* no redirection */ iop = nextfile(); if (iop == NULL) /* end of input */ return tmp_number((AWKNUM) 0.0); } else { rp = redirect(tree->rnode, &redir_error); if (rp == NULL && redir_error) /* failed redirect */ return tmp_number((AWKNUM) -1.0); iop = rp->iop; getline_redirect++; } if (tree->lnode == NULL) { /* no optional var. -- read in $0 */ if (inrec(iop) != 0) { getline_redirect = 0; return tmp_number((AWKNUM) 0.0); } } else { /* read in a named variable */ char *s = NULL; lhs = get_lhs(tree->lnode, 1); cnt = get_a_record(&s, iop); if (!getline_redirect) { assign_number(&NR_node->var_value, NR_node->var_value->numbr + 1.0); assign_number(&FNR_node->var_value, FNR_node->var_value->numbr + 1.0); } if (cnt == EOF) { getline_redirect = 0; free(s); return tmp_number((AWKNUM) 0.0); } *lhs = make_string(s, strlen(s)); do_deref(); /* we may have to regenerate $0 here! */ if (field_num == 0) set_record(fields_arr[0]->stptr, fields_arr[0]->stlen); field_num = -1; } getline_redirect = 0; return tmp_number((AWKNUM) 1.0);} :MPW:MPW Tools:Tools with Source:gawk:gawk-2.11:main.c
/* * main.c -- Expression tree constructors and main program for gawk. *//* * Copyright (C) 1986, 1988, 1989 the Free Software Foundation, Inc. * * This file is part of GAWK, the GNU implementation of the * AWK Progamming Language. * * GAWK is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 1, or (at your option) * any later version. * * GAWK is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with GAWK; see the file COPYING. If not, write to * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */#include "awk.h"#include "patchlevel.h"#include <signal.h>extern int yyparse();extern void do_input();extern int close_io();extern void init_fields();extern int getopt();extern int re_set_syntax();extern NODE *node();static void usage();static void set_fs();static void init_vars();static void init_args();static NODE *spc_var();static void pre_assign();static void copyleft();/* These nodes store all the special variables AWK uses */NODE *FS_node, *NF_node, *RS_node, *NR_node;NODE *FILENAME_node, *OFS_node, *ORS_node, *OFMT_node;NODE *FNR_node, *RLENGTH_node, *RSTART_node, *SUBSEP_node;NODE *ENVIRON_node, *IGNORECASE_node;NODE *ARGC_node, *ARGV_node;/* * The parse tree and field nodes are stored here. Parse_end is a dummy item * used to free up unneeded fields without freeing the program being run */int errcount = 0; /* error counter, used by yyerror() *//* The global null string */NODE *Nnull_string;/* The name the program was invoked under, for error messages */char *myname;/* A block of AWK code to be run before running the program */NODE *begin_block = 0;/* A block of AWK code to be run after the last input file */NODE *end_block = 0;int exiting = 0; /* Was an "exit" statement executed? */int exit_val = 0; /* optional exit value */#ifdef DEBUG/* non-zero means in debugging is enabled. Probably not very useful */int debugging = 1;extern int yydebug;#endifint tempsource = 0; /* source is in a temp file */char **sourcefile = NULL; /* source file name(s) */int numfiles = -1; /* how many source files */int strict = 0; /* turn off gnu extensions */int output_is_tty = 0; /* control flushing of output */NODE *expression_value;/* * for strict to work, legal options must be first * * Unfortunately, -a and -e are orthogonal to -c. */#define EXTENSIONS 8 /* where to clear */#ifdef DEBUGchar awk_opts[] = "F:f:v:caeCVdD";#elsechar awk_opts[] = "F:f:v:caeCV";#endif#ifdef THINK_C#include <console.h>char **environ;#endifintmain(argc, argv)int argc;char **argv;{#ifdef DEBUG /* Print out the parse tree. For debugging */ register int dotree = 0;#endif extern char *version_string; FILE *fp; int c; extern int opterr, optind; extern char *optarg; extern char *strrchr(); extern char *tmpnam(); extern SIGTYPE catchsig(); int i; int nostalgia;#ifdef somtime_in_the_future int regex_mode = RE_SYNTAX_POSIX_EGREP;#else int regex_mode = RE_SYNTAX_AWK;#endif (void) signal(SIGFPE, catchsig); (void) signal(SIGSEGV, catchsig); #ifdef THINK_C /* use the ccommand interface */ argc = ccommand(&argv); /* initialize environ to something safe */ *environ++ = ""; *environ = (char *) 0;#endif if (strncmp(version_string, "@(#)", 4) == 0) version_string += 4; myname = strrchr(argv[0], '/'); if (myname == NULL) myname = argv[0]; else myname++; if (argc < 2) usage(); /* initialize the null string */ Nnull_string = make_string("", 0); Nnull_string->numbr = 0.0; Nnull_string->type = Node_val; Nnull_string->flags = (PERM|STR|NUM|NUMERIC); /* Set up the special variables */ /* * Note that this must be done BEFORE arg parsing else -F * breaks horribly */ init_vars(); /* worst case */ emalloc(sourcefile, char **, argc * sizeof(char *), "main");#ifdef STRICT /* strict new awk compatibility */ strict = 1; awk_opts[EXTENSIONS] = '\0';#endif#ifndef STRICT /* undocumented feature, inspired by nostalgia, and a T-shirt */ nostalgia = 0; for (i = 1; i < argc && argv[i][0] == '-'; i++) { if (argv[i][1] == '-') /* -- */ break; else if (argv[i][1] == 'c') { /* compatibility mode */ nostalgia = 0; break; } else if (STREQ(&argv[i][1], "nostalgia")) nostalgia = 1; /* keep looping, in case -c after -nostalgia */ } if (nostalgia) { fprintf (stderr, "awk: bailing out near line 1\n"); abort(); }#endif while ((c = getopt (argc, argv, awk_opts)) != EOF) { switch (c) {#ifdef DEBUG case 'd': debugging++; dotree++; break; case 'D': debugging++; yydebug = 2; break;#endif#ifndef STRICT case 'c': strict = 1; break;#endif case 'F': set_fs(optarg); break; case 'f': /* * a la MKS awk, allow multiple -f options. * this makes function libraries real easy. * most of the magic is in the scanner. */ sourcefile[++numfiles] = optarg; break; case 'v': pre_assign(optarg); break; case 'V': fprintf(stderr, "%s, patchlevel %d\n", version_string, PATCHLEVEL); break; case 'C': copyleft(); break; case 'a': /* use old fashioned awk regexps */ regex_mode = RE_SYNTAX_AWK; break; case 'e': /* use egrep style regexps, per Posix */ regex_mode = RE_SYNTAX_POSIX_EGREP; break; case '?': default: /* getopt will print a message for us */ /* S5R4 awk ignores bad options and keeps going */ break; } } /* Tell the regex routines how they should work. . . */ (void) re_set_syntax(regex_mode);#ifdef DEBUG setbuf(stdout, (char *) NULL); /* make debugging easier */#endif if (isatty(fileno(stdout))) output_is_tty = 1; /* No -f option, use next arg */ /* write to temp file and save sourcefile name */ if (numfiles == -1) { int i; if (optind > argc - 1) /* no args left */ usage(); numfiles++; i = strlen (argv[optind]); if (i == 0) { /* sanity check */ fprintf(stderr, "%s: empty program text\n", myname); usage(); /* NOTREACHED */ } sourcefile[0] = tmpnam((char *) NULL); if ((fp = fopen (sourcefile[0], "w")) == NULL) fatal("could not save source prog in temp file (%s)", strerror(errno)); if (fwrite (argv[optind], 1, i, fp) == 0) fatal( "could not write source program to temp file (%s)", strerror(errno)); if (argv[optind][i-1] != '\n') putc ('\n', fp); (void) fclose (fp); tempsource++; optind++; } init_args(optind, argc, myname, argv); /* Read in the program */ if (yyparse() || errcount) exit(1);#ifdef DEBUG if (dotree) print_parse_tree(expression_value);#endif /* Set up the field variables */ init_fields(); if (begin_block) (void) interpret(begin_block); if (!exiting && (expression_value || end_block)) do_input(); if (end_block) (void) interpret(end_block); if (close_io() != 0 && exit_val == 0) exit_val = 1; exit(exit_val); /* NOTREACHED */ return exit_val;}static voidusage(){ char *opt1 = " -f progfile [--]"; char *opt2 = " [--] 'program'";#ifdef STRICT char *regops = " [-ae] [-F fs] [-v var=val]"#else char *regops = " [-aecCV] [-F fs] [-v var=val]";#endif fprintf(stderr, "usage: %s%s%s file ...\n %s%s%s file ...\n", myname, regops, opt1, myname, regops, opt2); exit(11);}/* Generate compiled regular expressions */struct re_pattern_buffer *make_regexp(s, ignorecase)NODE *s;int ignorecase;{ struct re_pattern_buffer *rp; char *err; emalloc(rp, struct re_pattern_buffer *, sizeof(*rp), "make_regexp"); memset((char *) rp, 0, sizeof(*rp)); emalloc(rp->buffer, char *, 16, "make_regexp"); rp->allocated = 16; emalloc(rp->fastmap, char *, 256, "make_regexp"); if (! strict && ignorecase) rp->translate = casetable; else rp->translate = NULL; if ((err = re_compile_pattern(s->stptr, s->stlen, rp)) != NULL) fatal("%s: /%s/", err, s->stptr); free_temp(s); return rp;}struct re_pattern_buffer *mk_re_parse(s, ignorecase)char *s;int ignorecase;{ char *src; register char *dest; register int c; int in_brack = 0; for (dest = src = s; *src != '\0';) { if (*src == '\\') { c = *++src; switch (c) { case '/': case 'a': case 'b': case 'f': case 'n': case 'r': case 't': case 'v': case 'x': case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': c = parse_escape(&src); if (c < 0) cant_happen(); *dest++ = (char)c; break; default: *dest++ = '\\'; *dest++ = (char)c; src++; break; } } else if (*src == '/' && ! in_brack) break; else { if (*src == '[') in_brack = 1; else if (*src == ']') in_brack = 0; *dest++ = *src++; } } return make_regexp(tmp_string(s, dest-s), ignorecase);}static voidcopyleft (){ extern char *version_string; char *cp; static char blurb[] ="Copyright (C) 1989, Free Software Foundation.\n\GNU Awk comes with ABSOLUTELY NO WARRANTY. This is free software, and\n\you are welcome to distribute it under the terms of the GNU General\n\Public License, which covers both the warranty information and the\n\terms for redistribution.\n\n\You should have received a copy of the GNU General Public License along\n\with this program; if not, write to the Free Software Foundation, Inc.,\n\675 Mass Ave, Cambridge, MA 02139, USA.\n"; fprintf (stderr, "%s, patchlevel %d\n", version_string, PATCHLEVEL); fputs(blurb, stderr); fflush(stderr);}static voidset_fs(str)char *str;{ register NODE **tmp; tmp = get_lhs(FS_node, 0); /* * Only if in full compatibility mode check for the stupid special * case so -F\t works as documented in awk even though the shell * hands us -Ft. Bleah! */ if (strict && str[0] == 't' && str[1] == '\0') str[0] = '\t'; *tmp = make_string(str, 1); do_deref();}static voidinit_args(argc0, argc, argv0, argv)int argc0, argc;char *argv0;char **argv;{ int i, j; NODE **aptr; ARGV_node = spc_var("ARGV", Nnull_string); aptr = assoc_lookup(ARGV_node, tmp_number(0.0)); *aptr = make_string(argv0, strlen(argv0)); for (i = argc0, j = 1; i < argc; i++) { aptr = assoc_lookup(ARGV_node, tmp_number((AWKNUM) j)); *aptr = make_string(argv[i], strlen(argv[i])); j++; } ARGC_node = spc_var("ARGC", make_number((AWKNUM) j));}/* * Set all the special variables to their initial values. */static voidinit_vars(){ extern char **environ; char *var, *val; NODE **aptr; int i; FS_node = spc_var("FS", make_string(" ", 1)); NF_node = spc_var("NF", make_number(-1.0)); RS_node = spc_var("RS", make_string("\n", 1)); NR_node = spc_var("NR", make_number(0.0)); FNR_node = spc_var("FNR", make_number(0.0)); FILENAME_node = spc_var("FILENAME", make_string("-", 1)); OFS_node = spc_var("OFS", make_string(" ", 1)); ORS_node = spc_var("ORS", make_string("\n", 1)); OFMT_node = spc_var("OFMT", make_string("%.6g", 4)); RLENGTH_node = spc_var("RLENGTH", make_number(0.0)); RSTART_node = spc_var("RSTART", make_number(0.0)); SUBSEP_node = spc_var("SUBSEP", make_string("\034", 1)); IGNORECASE_node = spc_var("IGNORECASE", make_number(0.0)); ENVIRON_node = spc_var("ENVIRON", Nnull_string); for (i = 0; environ[i]; i++) { static char nullstr[] = ""; var = environ[i]; val = strchr(var, '='); if (val) *val++ = '\0'; else val = nullstr; aptr = assoc_lookup(ENVIRON_node, tmp_string(var, strlen (var))); *aptr = make_string(val, strlen (val)); /* restore '=' so that system() gets a valid environment */ if (val != nullstr) *--val = '='; }}/* Create a special variable */static NODE *spc_var(name, value)char *name;NODE *value;{ register NODE *r; if ((r = lookup(variables, name)) == NULL) r = install(variables, name, node(value, Node_var, (NODE *) NULL)); return r;}static voidpre_assign(v)char *v;{ char *cp; cp = strchr(v, '='); if (cp != NULL) { *cp++ = '\0'; variable(v)->var_value = make_string(cp, strlen(cp)); } else { fprintf (stderr, "%s: '%s' argument to -v not in 'var=value' form\n", myname, v); usage(); }}SIGTYPEcatchsig(sig, code)int sig, code;{#ifdef lint code = 0; sig = code; code = sig;#endif if (sig == SIGFPE) { fatal("floating point exception"); } else if (sig == SIGSEGV) { msg("fatal error: segmentation fault"); /* fatal won't abort() if not compiled for debugging */ abort(); } else cant_happen(); /* NOTREACHED */} :MPW:MPW Tools:Tools with Source:gawk:gawk-2.11:Makefile
# Makefile for GNU Awk.## Copyright (C) 1986, 1988, 1989 the Free Software Foundation, Inc.# # This file is part of GAWK, the GNU implementation of the# AWK Progamming Language.# # GAWK is free software; you can redistribute it and/or modify# it under the terms of the GNU General Public License as published by# the Free Software Foundation; either version 1, or (at your option)# any later version.# # GAWK is distributed in the hope that it will be useful,# but WITHOUT ANY WARRANTY; without even the implied warranty of# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the# GNU General Public License for more details.# # You should have received a che GNU General Public License# along with GAWK; see the file COPYING. If not, write to# the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.# User tunable macros# CFLAGS: options to the C compiler## -O optimize# -g include dbx/sdb info# -gg include gdb debugging info; only for GCC (deprecated)# -pg include new (gmon) profiling info# -p include old style profiling info (System V)## To port GAWK, examine and adjust the following flags carefully.# In addition, you will have to look at alloca below.# The intent (eventual) is to not penalize the most-standard-conforming# systems with a lot of #define's.## -DBCOPY_MISSING - bcopy() et al. are missing; will replace# with a #define'd memcpy() et al. -- use at# your own risk (should really use a memmove())# -DSPRINTF_INT - sprintf() returns int (most USG systems)# -DBLKSIZE_MISSING - st_blksize missing from stat() structure# (most USG systems)# -DBSDSTDIO - has a BSD internally-compatible stdio# -DDOPRNT_MISSING - lacks doprnt() routine# -DDUP2_MISSING - lacks dup2() system call (S5Rn, n < 4)# -DGCVT_MISSING - lacks gcvt() routine# -DGETOPT_MISSING - lacks getopt() routine# -DMEMCMP_MISSING - lacks memcmp() routine# -DMEMCPY_MISSING - lacks memcpy() routine# -DMEMSET_MISSING - lacks memset() routine# -DRANDOM_MISSING - lacks random() routine# -DSTRCASE_MISSING - lacks strcasecmp() routine# -DSTRCHR_MISSING - lacks strchr() and strrchr() routines# -DSTRERROR_MISSING - lacks (ANSI C) strerror() routine# -DSTRTOD_MISSING - lacks strtod() routine# -DTMPNAM_MISSING - lacks or deficient tmpnam() routine# -DVPRINTF_MISSING - lacks vprintf and associated routines# -DSIGTYPE=int - signal routines return int (default void)# Sun running SunOS 4.xMISSING = -DSTRERROR_MISSING -DSTRCASE_MISSING# SGI Personal Iris (Sys V derived)# MISSING = -DSPRINTF_INT -DBLKSIZE_MISSING -DSTRERROR_MISSING -DRANDOM_MISSING# VAX running Ultrix 3.x# MISSING = -DSTRERROR_MISSING# A generic 4.2 BSD machine# (eliminate GETOPT_MISSING for 4.3 release)# (eliminate STRCASE_MISSING and TMPNAM_MISSING for Tahoe release)# MISSING = -DBSDSTDIO -DMEMCMP_MISSING -DMEMCPY_MISSING -DMEMSET_MISSING \# -DSTRERROR_MISSING -DSTRTOD_MISSING -DVPRINTF_MISSING \# -DSTRCASE_MISSING -DTMPNAM_MISSING \# -DGETOPT_MISSING -DSTRCHR_MISSING -DSIGTYPE=int# On Amdahl UTS, a SysVr2-derived system# MISSING = -DBCOPY_MISSING -DSPRINTF_INT -DRANDOM_MISSING -DSTRERROR_MISSING \# -DSTRCASE_MISSING -DDUP2_MISSING # -DBLKSIZE_MISSING ??????# Comment out the next line if you don't have gcc.# Also choose just one of -g and -O.CC= gccOPTIMIZE= -O -gPROFILE= #-pgDEBUG= #-DDEBUG #-DMEMDEBUG #-DFUNC_TRACE #-DMPROFDEBUGGER= #-g -BstaticWARN= #-W -Wunused -Wimplicit -Wreturn-type -Wcomment # for gcc only# Parser to use on grammar -- if you don't have bison use the first one#PARSER = yaccPARSER = bison# ALLOCA# Set equal to alloca.o if your system is S5 and you don't have# alloca. Uncomment one of the rules below to make alloca.o from# either alloca.s or alloca.c.ALLOCA= #alloca.o## With the exception of the alloca rule referred to above, you shouldn't# need to customize this file below this point.#FLAGS= $(MISSING) $(DEBUG)CFLAGS= $(FLAGS) $(DEBUGGER) $(PROFILE) $(OPTIMIZE) $(WARN)# object filesAWKOBJS = main.o eval.o builtin.o msg.o debug.o io.o field.o array.o node.o \ version.o missing.oALLOBJS = $(AWKOBJS) awk.tab.o# GNUOBJS# GNU stuff that gawk uses as library routines.GNUOBJS= regex.o $(ALLOCA)# source and documentation filesSRC = main.c eval.c builtin.c msg.c \ debug.c io.c field.c array.c node.c missing.cALLSRC= $(SRC) awk.tab.cAWKSRC= awk.h awk.y $(ALLSRC) version.sh patchlevel.hGNUSRC = alloca.c alloca.s regex.c regex.hCOPIES = missing.d/dup2.c missing.d/gcvt.c missing.d/getopt.c \ missing.d/memcmp.c missing.d/memcpy.c missing.d/memset.c \ missing.d/random.c missing.d/strcase.c missing.d/strchr.c \ missing.d/strerror.c missing.d/strtod.c missing.d/tmpnam.c \ missing.d/vprintf.cSUPPORT = support/texindex.c support/texinfo.texDOCS= gawk.1 gawk.texinfoINFOFILES= gawk-info gawk-info-1 gawk-info-2 gawk-info-3 gawk-info-4 \ gawk-info-5 gawk-info-6 gawk.aux gawk.cp gawk.cps gawk.fn \ gawk.fns gawk.ky gawk.kys gawk.pg gawk.pgs gawk.toc \ gawk.tp gawk.tps gawk.vr gawk.vrsMISC = CHANGES COPYING FUTURES Makefile PROBLEMS READMEPCSTUFF= pc.d/Makefile.pc pc.d/popen.c pc.d/popen.hALLDOC= gawk.dvi $(INFOFILES)ALLFILES= $(AWKSRC) $(GNUSRC) $(COPIES) $(MISC) $(DOCS) $(ALLDOC) $(PCSTUFF) $(SUPPORT)# Release of gawk. There can be no leading or trailing white space here!REL=2.11# rules to build gawkgawk: $(ALLOBJS) $(GNUOBJS) $(CC) -o gawk $(CFLAGS) $(ALLOBJS) $(GNUOBJS) -lm$(AWKOBJS): awk.hmain.o: patchlevel.hawk.tab.o: awk.h awk.tab.cawk.tab.c: awk.y $(PARSER) -v awk.y -mv -f y.tab.c awk.tab.cversion.c: version.sh sh version.sh $(REL) > version.c# Alloca: uncomment this if your system (notably System V boxen)# does not have alloca in /lib/libc.a##alloca.o: alloca.s# /lib/cpp < alloca.s | sed '/^#/d' > t.s# as t.s -o alloca.o# rm t.s# If your machine is not supported by the assembly version of alloca.s,# use the C version instead. This uses the default rules to make alloca.o.##alloca.o: alloca.c# auxiliary rules for release maintenancelint: $(ALLSRC) lint -hcbax $(FLAGS) $(ALLSRC)xref: cxref -c $(FLAGS) $(ALLSRC) | grep -v ' /' >xrefclean: rm -f gawk *.o core awk.output awk.tab.c gmon.out make.out version.cclobber: clean rm -f $(ALLDOC) gawk.loggawk.dvi: gawk.texinfo tex gawk.texinfo ; texindex gawk.?? tex gawk.texinfo ; texindex gawk.?? tex gawk.texinfo$(INFOFILES): gawk.texinfo makeinfo gawk.texinfosrcrelease: $(AWKSRC) $(GNUSRC) $(DOCS) $(MISC) $(COPIES) $(PCSTUFF) $(SUPPORT) -mkdir gawk-$(REL) cp -p $(AWKSRC) $(GNUSRC) $(DOCS) $(MISC) gawk-$(REL) -mkdir gawk-$(REL)/missing.d cp -p $(COPIES) gawk-$(REL)/missing.d -mkdir gawk-$(REL)/pc.d cp -p $(PCSTUFF) gawk-$(REL)/pc.d -mkdir gawk-$(REL)/support cp -p $(SUPPORT) gawk-$(REL)/support tar -cf - gawk-$(REL) | compress > gawk-$(REL).tar.Zdocrelease: $(ALLDOC) -mkdir gawk-$(REL)-doc cp -p $(INFOFILES) gawk.dvi gawk-$(REL)-doc nroff -man gawk.1 > gawk-$(REL)-doc/gawk.1.pr tar -cf - gawk-$(REL)-doc | compress > gawk-doc-$(REL).tar.Zpsrelease: docrelease -mkdir gawk-postscript dvi2ps gawk.dvi > gawk-postscript/gawk.postscript psroff -t -man gawk.1 > gawk-postscript/gawk.1.ps tar -cf - gawk-postscript | compress > gawk.postscript.tar.Zrelease: srcrelease docrelease psrelease rm -fr gawk-postscript gawk-$(REL) gawk-$(REL)-docdiff: for i in RCS/*; do rcsdiff -c -b $$i > `basename $$i ,v`.diff; done :MPW:MPW Tools:Tools with Source:gawk:gawk-2.11:missing.c
/*** @(#)getopt.c 2.5 (smail) 9/15/87*//* * Here's something you've all been waiting for: the AT&T public domain * source for getopt(3). It is the code which was given out at the 1985 * UNIFORUM conference in Dallas. I obtained it by electronic mail * directly from AT&T. The people there assure me that it is indeed * in the public domain. * * There is no manual page. That is because the one they gave out at * UNIFORUM was slightly different from the current System V Release 2 * manual page. The difference apparently involved a note about the * famous rules 5 and 6, recommending using white space between an option * and its first argument, and not grouping options that have arguments. * Getopt itself is currently lenient about both of these things White * space is allowed, but not mandatory, and the last option in a group can * have an argument. That particular version of the man page evidently * has no official existence, and my source at AT&T did not send a copy. * The current SVR2 man page reflects the actual behavor of this getopt. * However, I am not about to post a copy of anything licensed by AT&T. */#if defined(MSDOS) || defined(USG)#define index strchr#endif/*LINTLIBRARY*/#ifndef NULL#define NULL 0#endif#ifndef EOF#define EOF (-1)#endif#define ERR(s, c) if(opterr){\ extern int write();\ char errbuf[2];\ errbuf[0] = c; errbuf[1] = '\n';\ (void) write(2, argv[0], (unsigned)strlen(argv[0]));\ (void) write(2, s, (unsigned)strlen(s));\ (void) write(2, errbuf, 2);}extern char *index();int opterr = 1;int optind = 1;int optopt;char *optarg;intgetopt(argc, argv, opts)int argc;char **argv, *opts;{ static int sp = 1; register int c; register char *cp; if(sp == 1) if(optind >= argc || argv[optind][0] != '-' || argv[optind][1] == '\0') return(EOF); else if(strcmp(argv[optind], "--") == NULL) { optind++; return(EOF); } optopt = c = argv[optind][sp]; if(c == ':' || (cp=index(opts, c)) == NULL) { ERR(": illegal option -- ", c); if(argv[optind][++sp] == '\0') { optind++; sp = 1; } return('?'); } if(*++cp == ':') { if(argv[optind][sp+1] != '\0') optarg = &argv[optind++][sp+1]; else if(++optind >= argc) { ERR(": option requires an argument -- ", c); sp = 1; return('?'); } else optarg = argv[optind++]; sp = 1; } else { if(argv[optind][++sp] == '\0') { sp = 1; optind++; } optarg = NULL; } return(c);} :MPW:MPW Tools:Tools with Source:gawk:gawk-2.11:missing.d:memcmp.c
/* * memcmp --- compare strings. * * We use our own routine since it has to act like strcmp() for return * value, and the BSD manual says bcmp() only returns zero/non-zero. */intmemcmp (s1, s2, l)register char *s1, *s2;register int l;{ for (; l--; s1++, s2++) { if (*s1 != *s2) return (*s1 - *s2); } return (*--s1 - *--s2);} :MPW:MPW Tools:Tools with Source:gawk:gawk-2.11:missing.d:memcpy.c
/* * memcpy --- copy strings. * * We supply this routine for those systems that aren't standard yet. */char *memcpy (dest, src, l)register char *dest, *src;register int l;{ register char *ret = dest; while (l--) *dest++ = *src++; return ret;} :MPW:MPW Tools:Tools with Source:gawk:gawk-2.11:missing.d:memset.c
/* * memset --- initialize memory * * We supply this routine for those systems that aren't standard yet. */char *memset (dest, val, l)register char *dest, val;register int l;{ register char *ret = dest; while (l--) *dest++ = val; return ret;} :MPW:MPW Tools:Tools with Source:gawk:gawk-2.11:missing.d:random.c
/* * Copyright (c) 1983 Regents of the University of California. * All rights reserved. * * Redistribution and use in source and binary forms are permitted * provided that the above copyright notice and this paragraph are * duplicated in all such forms and that any documentation, * advertising materials, and other materials related to such * distribution and use acknowledge that the software was developed * by the University of California, Berkeley. The name of the * University may not be used to endorse or promote products derived * from this software without specific prior written permission. * THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED * WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. */#if defined(LIBC_SCCS) && !defined(lint)static char sccsid[] = "@(#)random.c 5.5 (Berkeley) 7/6/88";#endif /* LIBC_SCCS and not lint */#include <stdio.h>/* * random.c: * An improved random number generation package. In addition to the standard * rand()/srand() like interface, this package also has a special state info * interface. The initstate() routine is called with a seed, an array of * bytes, and a count of how many bytes are being passed in; this array is then * initialized to contain information for random number generation with that * much state information. Good sizes for the amount of state information are * 32, 64, 128, and 256 bytes. The state can be switched by calling the * setstate() routine with the same array as was initiallized with initstate(). * By default, the package runs with 128 bytes of state information and * generates far better random numbers than a linear congruential generator. * If the amount of state information is less than 32 bytes, a simple linear * congruential R.N.G. is used. * Internally, the state information is treated as an array of longs; the * zeroeth element of the array is the type of R.N.G. being used (small * integer); the remainder of the array is the state information for the * R.N.G. Thus, 32 bytes of state information will give 7 longs worth of * state information, which will allow a degree seven polynomial. (Note: the * zeroeth word of state information also has some other information stored * in it -- see setstate() for details). * The random number generation technique is a linear feedback shift register * approach, employing trinomials (since there are fewer terms to sum up that * way). In this approach, the least significant bit of all the numbers in * the state table will act as a linear feedback shift register, and will have * period 2^deg - 1 (where deg is the degree of the polynomial being used, * assuming that the polynomial is irreducible and primitive). The higher * order bits will have longer periods, since their values are also influenced * by pseudo-random carries out of the lower bits. The total period of the * generator is approximately deg*(2**deg - 1); thus doubling the amount of * state information has a vast influence on the period of the generator. * Note: the deg*(2**deg - 1) is an approximation only good for large deg, * when the period of the shift register is the dominant factor. With deg * equal to seven, the period is actually much longer than the 7*(2**7 - 1) * predicted by this formula. *//* * For each of the currently supported random number generators, we have a * break value on the amount of state information (you need at least this * many bytes of state info to support this random number generator), a degree * for the polynomial (actually a trinomial) that the R.N.G. is based on, and * the separation between the two lower order coefficients of the trinomial. */#define TYPE_0 0 /* linear congruential */#define BREAK_0 8#define DEG_0 0#define SEP_0 0#define TYPE_1 1 /* x**7 + x**3 + 1 */#define BREAK_1 32#define DEG_1 7#define SEP_1 3#define TYPE_2 2 /* x**15 + x + 1 */#define BREAK_2 64#define DEG_2 15#define SEP_2 1#define TYPE_3 3 /* x**31 + x**3 + 1 */#define BREAK_3 128#define DEG_3 31#define SEP_3 3#define TYPE_4 4 /* x**63 + x + 1 */#define BREAK_4 256#define DEG_4 63#define SEP_4 1/* * Array versions of the above information to make code run faster -- relies * on fact that TYPE_i == i. */#define MAX_TYPES 5 /* max number of types above */static int degrees[ MAX_TYPES ] = { DEG_0, DEG_1, DEG_2, DEG_3, DEG_4 };static int seps[ MAX_TYPES ] = { SEP_0, SEP_1, SEP_2, SEP_3, SEP_4 };/* * Initially, everything is set up as if from : * initstate( 1, &randtbl, 128 ); * Note that this initialization takes advantage of the fact that srandom() * advances the front and rear pointers 10*rand_deg times, and hence the * rear pointer which starts at 0 will also end up at zero; thus the zeroeth * element of the state information, which contains info about the current * position of the rear pointer is just * MAX_TYPES*(rptr - state) + TYPE_3 == TYPE_3. */static long randtbl[ DEG_3 + 1 ] = { TYPE_3, 0x9a319039, 0x32d9c024, 0x9b663182, 0x5da1f342, 0xde3b81e0, 0xdf0a6fb5, 0xf103bc02, 0x48f340fb, 0x7449e56b, 0xbeb1dbb0, 0xab5c5918, 0x946554fd, 0x8c2e680f, 0xeb3d799f, 0xb11ee0b7, 0x2d436b86, 0xda672e2a, 0x1588ca88, 0xe369735d, 0x904f35f7, 0xd7158fd6, 0x6fa6f051, 0x616e6b96, 0xac94efdc, 0x36413f93, 0xc622c298, 0xf5a42ab8, 0x8a88d77b, 0xf5ad9d0e, 0x8999220b, 0x27fb47b9 };/* * fptr and rptr are two pointers into the state info, a front and a rear * pointer. These two pointers are always rand_sep places aparts, as they cycle * cyclically through the state information. (Yes, this does mean we could get * away with just one pointer, but the code for random() is more efficient this * way). The pointers are left positioned as they would be from the call * initstate( 1, randtbl, 128 ) * (The position of the rear pointer, rptr, is really 0 (as explained above * in the initialization of randtbl) because the state table pointer is set * to point to randtbl[1] (as explained below). */static long *fptr = &randtbl[ SEP_3 + 1 ];static long *rptr = &randtbl[ 1 ];/* * The following things are the pointer to the state information table, * the type of the current generator, the degree of the current polynomial * being used, and the separation between the two pointers. * Note that for efficiency of random(), we remember the first location of * the state information, not the zeroeth. Hence it is valid to access * state[-1], which is used to store the type of the R.N.G. * Also, we remember the last location, since this is more efficient than * indexing every time to find the address of the last element to see if * the front and rear pointers have wrapped. */static long *state = &randtbl[ 1 ];static int rand_type = TYPE_3;static int rand_deg = DEG_3;static int rand_sep = SEP_3;static long *end_ptr = &randtbl[ DEG_3 + 1 ];/* * srandom: * Initialize the random number generator based on the given seed. If the * type is the trivial no-state-information type, just remember the seed. * Otherwise, initializes state[] based on the given "seed" via a linear * congruential generator. Then, the pointers are set to known locations * that are exactly rand_sep places apart. Lastly, it cycles the state * information a given number of times to get rid of any initial dependencies * introduced by the L.C.R.N.G. * Note that the initialization of randtbl[] for default usage relies on * values produced by this routine. */srandom( x ) unsigned x;{ register int i, j; long random(); if( rand_type == TYPE_0 ) { state[ 0 ] = x; } else { j = 1; state[ 0 ] = x; for( i = 1; i < rand_deg; i++ ) { state[i] = 1103515245*state[i - 1] + 12345; } fptr = &state[ rand_sep ]; rptr = &state[ 0 ]; for( i = 0; i < 10*rand_deg; i++ ) random(); }}/* * initstate: * Initialize the state information in the given array of n bytes for * future random number generation. Based on the number of bytes we * are given, and the break values for the different R.N.G.'s, we choose * the best (largest) one we can and set things up for it. srandom() is * then called to initialize the state information. * Note that on return from srandom(), we set state[-1] to be the type * multiplexed with the current value of the rear pointer; this is so * successive calls to initstate() won't lose this information and will * be able to restart with setstate(). * Note: the first thing we do is save the current state, if any, just like * setstate() so that it doesn't matter when initstate is called. * Returns a pointer to the old state. */char *initstate( seed, arg_state, n ) unsigned seed; /* seed for R. N. G. */ char *arg_state; /* pointer to state array */ int n; /* # bytes of state info */{ register char *ostate = (char *)( &state[ -1 ] ); if( rand_type == TYPE_0 ) state[ -1 ] = rand_type; else state[ -1 ] = MAX_TYPES*(rptr - state) + rand_type; if( n < BREAK_1 ) { if( n < BREAK_0 ) { fprintf( stderr, "initstate: not enough state (%d bytes) with which to do jack; ignored.\n", n ); return 0; } rand_type = TYPE_0; rand_deg = DEG_0; rand_sep = SEP_0; } else { if( n < BREAK_2 ) { rand_type = TYPE_1; rand_deg = DEG_1; rand_sep = SEP_1; } else { if( n < BREAK_3 ) { rand_type = TYPE_2; rand_deg = DEG_2; rand_sep = SEP_2; } else { if( n < BREAK_4 ) { rand_type = TYPE_3; rand_deg = DEG_3; rand_sep = SEP_3; } else { rand_type = TYPE_4; rand_deg = DEG_4; rand_sep = SEP_4; } } } } state = &( ( (long *)arg_state )[1] ); /* first location */ end_ptr = &state[ rand_deg ]; /* must set end_ptr before srandom */ srandom( seed ); if( rand_type == TYPE_0 ) state[ -1 ] = rand_type; else state[ -1 ] = MAX_TYPES*(rptr - state) + rand_type; return( ostate );}/* * setstate: * Restore the state from the given state array. * Note: it is important that we also remember the locations of the pointers * in the current state information, and restore the locations of the pointers * from the old state information. This is done by multiplexing the pointer * location into the zeroeth word of the state information. * Note that due to the order in which things are done, it is OK to call * setstate() with the same state as the current state. * Returns a pointer to the old state information. */char *setstate( arg_state ) char *arg_state;{ register long *new_state = (long *)arg_state; register int type = new_state[0]%MAX_TYPES; register int rear = new_state[0]/MAX_TYPES; char *ostate = (char *)( &state[ -1 ] ); if( rand_type == TYPE_0 ) state[ -1 ] = rand_type; else state[ -1 ] = MAX_TYPES*(rptr - state) + rand_type; switch( type ) { case TYPE_0: case TYPE_1: case TYPE_2: case TYPE_3: case TYPE_4: rand_type = type; rand_deg = degrees[ type ]; rand_sep = seps[ type ]; break; default: fprintf( stderr, "setstate: state info has been munged; not changed.\n" ); } state = &new_state[ 1 ]; if( rand_type != TYPE_0 ) { rptr = &state[ rear ]; fptr = &state[ (rear + rand_sep)%rand_deg ]; } end_ptr = &state[ rand_deg ]; /* set end_ptr too */ return( ostate );}/* * random: * If we are using the trivial TYPE_0 R.N.G., just do the old linear * congruential bit. Otherwise, we do our fancy trinomial stuff, which is the * same in all ther other cases due to all the global variables that have been * set up. The basic operation is to add the number at the rear pointer into * the one at the front pointer. Then both pointers are advanced to the next * location cyclically in the table. The value returned is the sum generated, * reduced to 31 bits by throwing away the "least random" low bit. * Note: the code takes advantage of the fact that both the front and * rear pointers can't wrap on the same call by not testing the rear * pointer if the front one has wrapped. * Returns a 31-bit random number. */longrandom(){ long i; if( rand_type == TYPE_0 ) { i = state[0] = ( state[0]*1103515245 + 12345 )&0x7fffffff; } else { *fptr += *rptr; i = (*fptr >> 1)&0x7fffffff; /* chucking least random bit */ if( ++fptr >= end_ptr ) { fptr = state; ++rptr; } else { if( ++rptr >= end_ptr ) rptr = state; } } return( i );} :MPW:MPW Tools:Tools with Source:gawk:gawk-2.11:missing.d:strcase.c
/* * Copyright (c) 1987 Regents of the University of California. * All rights reserved. * * Redistribution andsource and binary forms are permitted * provided that the above copyright notice and this paragraph are * duplicated in all such forms and that any documentation, * advertising materials, and other materials related to such * distribution and use acknowledge that the software was developed * by the University of California, Berkeley. The name of the * University may not be used to endorse or promote products derived * from this software without specific prior written permission. * THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED * WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. */#if defined(LIBC_SCCS) && !defined(lint)static char sccsid[] = "@(#)strcasecmp.c 5.6 (Berkeley) 6/27/88";#endif /* LIBC_SCCS and not lint */#ifndef USG#ifndef THINK_C#include <sys/types.h>#else#define u_char unsigned char#endif#endif/* * This array is designed for mapping upper and lower case letter * together for a case independent comparison. The mappings are * based upon ascii character sequences. */static u_char charmap[] = { '\000', '\001', '\002', '\003', '\004', '\005', '\006', '\007', '\010', '\011', '\012', '\013', '\014', '\015', '\016', '\017', '\020', '\021', '\022', '\023', '\024', '\025', '\026', '\027', '\030', '\031', '\032', '\033', '\034', '\035', '\036', '\037', '\040', '\041', '\042', '\043', '\044', '\045', '\046', '\047', '\050', '\051', '\052', '\053', '\054', '\055', '\056', '\057', '\060', '\061', '\062', '\063', '\064', '\065', '\066', '\067', '\070', '\071', '\072', '\073', '\074', '\075', '\076', '\077', '\100', '\141', '\142', '\143', '\144', '\145', '\146', '\147', '\150', '\151', '\152', '\153', '\154', '\155', '\156', '\157', '\160', '\161', '\162', '\163', '\164', '\165', '\166', '\167', '\170', '\171', '\172', '\133', '\134', '\135', '\136', '\137', '\140', '\141', '\142', '\143', '\144', '\145', '\146', '\147', '\150', '\151', '\152', '\153', '\154', '\155', '\156', '\157', '\160', '\161', '\162', '\163', '\164', '\165', '\166', '\167', '\170', '\171', '\172', '\173', '\174', '\175', '\176', '\177', '\200', '\201', '\202', '\203', '\204', '\205', '\206', '\207', '\210', '\211', '\212', '\213', '\214', '\215', '\216', '\217', '\220', '\221', '\222', '\223', '\224', '\225', '\226', '\227', '\230', '\231', '\232', '\233', '\234', '\235', '\236', '\237', '\240', '\241', '\242', '\243', '\244', '\245', '\246', '\247', '\250', '\251', '\252', '\253', '\254', '\255', '\256', '\257', '\260', '\261', '\262', '\263', '\264', '\265', '\266', '\267', '\270', '\271', '\272', '\273', '\274', '\275', '\276', '\277', '\300', '\341', '\342', '\343', '\344', '\345', '\346', '\347', '\350', '\351', '\352', '\353', '\354', '\355', '\356', '\357', '\360', '\361', '\362', '\363', '\364', '\365', '\366', '\367', '\370', '\371', '\372', '\333', '\334', '\335', '\336', '\337', '\340', '\341', '\342', '\343', '\344', '\345', '\346', '\347', '\350', '\351', '\352', '\353', '\354', '\355', '\356', '\357', '\360', '\361', '\362', '\363', '\364', '\365', '\366', '\367', '\370', '\371', '\372', '\373', '\374', '\375', '\376', '\377',};strcasecmp(s1, s2) char *s1, *s2;{ register u_char *cm = charmap, *us1 = (u_char *)s1, *us2 = (u_char *)s2; while (cm[*us1] == cm[*us2++]) if (*us1++ == '\0') return(0); return(cm[*us1] - cm[*--us2]);}strncasecmp(s1, s2, n) char *s1, *s2; register int n;{ register u_char *cm = charmap, *us1 = (u_char *)s1, *us2 = (u_char *)s2; while (--n >= 0 && cm[*us1] == cm[*us2++]) if (*us1++ == '\0') return(0); return(n < 0 ? 0 : cm[*us1] - cm[*--us2]);} :MPW:MPW Tools:Tools with Source:gawk:gawk-2.11:missing.d:strchr.c
/* * strchr --- search a string for a character * * We supply this routine for those systems that aren't standard yet. */char *strchr (str, c)register char *str, c;{ for (; *str; str++) if (*str == c) return str; return NULL;}/* * strrchr --- find the last occurrence of a character in a string * * We supply this routine for those systems that aren't standard yet. */char *strrchr (str, c)register char *str, c;{ register char *save = NULL; for (; *str; str++) if (*str == c) save = str; return save;} :MPW:MPW Tools:Tools with Source:gawk:gawk-2.11:missing.d:strerror.c
/* * strerror.c --- ANSI C compatible system error routine *//* * Copyright (C) 1986, 1988, 1989 the Free Software Foundation, Inc. * * This file is part of GAWK, the GNU implementation of the * AWK Progamming Language. * * GAWK is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 1, or (at your option) * any later version. * * GAWK is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with GAWK; see the file COPYING. If not, write to * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */extern int sys_nerr;extern char *sys_errlist[];/* have to get right decl of sprintf early on */#ifndef BUFSIZ /* stdio specific definition */#include <stdio.h>#endifchar *strerror(n)int n;{ static char mesg[30]; if (n < 0 || n > sys_nerr) { sprintf (mesg, "Unknown error (%d)", n); return mesg; } else return sys_errlist[n];} :MPW:MPW Tools:Tools with Source:gawk:gawk-2.11:missing.d:strtod.c
/* * strtod.c * * Stupid version of System V strtod(3) library routine. * Does no overflow/underflow checking. * * A real number is defined to be * optional leading white space * optional sign * string of digits with optional decimal point * optional 'e' or 'E' * followed by optional sign or space * followed by an integer * * if ptr is not NULL a pointer to the character terminating the * scan is returned in *ptr. If no number formed, *ptr is set to str * and 0 is returned. * * For speed, we don't do the conversion ourselves. Instead, we find * the end of the number and then call atof() to do the dirty work. * This bought us a 10% speedup on a sample program at uunet.uu.net. */#include <ctype.h>extern double atof();doublestrtod (s, ptr)register char *s, **ptr;{ double ret = 0.0; char *start = s; char *begin = NULL; int success = 0; /* optional white space */ while (isspace(*s)) s++; /* optional sign */ if (*s == '+' || *s == '-') { s++; if (*(s-1) == '-') begin = s - 1; else begin = s; } /* string of digits with optional decimal point */ if (isdigit(*s) && ! begin) begin = s; while (isdigit(*s)) { s++; success++; } if (*s == '.') { if (! begin) begin = s; s++; while (isdigit(*s)) s++; success++; } if (s == start || success == 0) /* nothing there */ goto out; /* * optional 'e' or 'E' * followed by optional sign or space * followed by an integer */ if (*s == 'e' || *s == 'E') { s++; /* XXX - atof probably doesn't allow spaces here */ while (isspace(*s)) s++; if (*s == '+' || *s == '-') s++; while (isdigit(*s)) s++; } /* go for it */ ret = atof(begin);out: if (! success) s = start; /* in case all we did was skip whitespace */ if (ptr) *ptr = s; return ret;}#ifdef TESTmain (argc, argv)int argc;char **argv;{ double d; char *p; for (argc--, argv++; argc; argc--, argv++) { d = strtod (*argv, & p); printf ("%lf [%s]\n", d, p); }}#endif :MPW:MPW Tools:Tools with Source:gawk:gawk-2.11:missing.d:tmpnam.c
/* * tmpnam - an implementation for systems lacking a library version * this version does not rely on the P_tmpdir and L_tmpnam constants. */#ifndef NULL#define NULL 0#endifstatic char template[] = "/tmp/gawkXXXXXX";char *tmpnam(tmp)char *tmp;{ static char tmpbuf[sizeof(template)]; if (tmp == NULL) { (void) strcpy(tmpbuf, template); (void) mktemp(tmpbuf); return tmpbuf; } else { (void) strcpy(tmp, template); (void) mktemp(tmp); return tmp; }} :MPW:MPW Tools:Tools with Source:gawk:gawk-2.11:missing.d:vprintf.c
#include <stdio.h>#include <varargs.h>#ifndef BUFSIZ#include <stdio.h>#endif#ifndef va_dcl#include <varargs.h>#endifintvsprintf(str, fmt, ap) char *str, *fmt; va_list ap;{ FILE f; int len; f._flag = _IOWRT+_IOSTRG; f._ptr = (char *)str; /* My copy of BSD stdio.h has this as (char *) * with a comment that it should be * (unsigned char *). Since this code is * intended for use on a vanilla BSD system, * we'll stick with (char *) for now. */ f._cnt = 32767; len = _doprnt(fmt, ap, &f); *f._ptr = 0; return (len);}intvfprintf(iop, fmt, ap) FILE *iop; char *fmt; va_list ap;{ int len; len = _doprnt(fmt, ap, iop); return (ferror(iop) ? EOF : len);}intvprintf(fmt, ap) char *fmt; va_list ap;{ int len; len = _doprnt(fmt, ap, stdout); return (ferror(stdout) ? EOF : len);} :MPW:MPW Tools:Tools with Source:gawk:gawk-2.11:msg.c
/* * msg.c - routines for error messages *//* * Copyright (C) 1986, 1988, 1989 the Free Software Foundation, Inc. * * This file is part of GAWK, the GNU implementation of the * AWK Progamming Language. * * GAWK is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 1, or (at your option) * any later version. * * GAWK is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with GAWK; see the file COPYING. If not, write to * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */#include "awk.h"int sourceline = 0;char *source = NULL;/* VARARGS2 */static voiderr(char *s, char *msg, va_list *argp){ int line; char *file; (void) fprintf(stderr, "%s: %s ", myname, s); vfprintf(stderr, msg, *argp); (void) fprintf(stderr, "\n"); line = (int) FNR_node->var_value->numbr; if (line) { (void) fprintf(stderr, " input line number %d", line); file = FILENAME_node->var_value->stptr; if (file && !STREQ(file, "-")) (void) fprintf(stderr, ", file `%s'", file); (void) fprintf(stderr, "\n"); } if (sourceline) { (void) fprintf(stderr, " source line number %d", sourceline); if (source) (void) fprintf(stderr, ", file `%s'", source); (void) fprintf(stderr, "\n"); }}/*VARARGS0*/voidmsg(char *fmt,...){ va_list args; va_start(args, fmt); err("", fmt, &args); va_end(args);}/*VARARGS0*/voidwarning(char *fmt,...){ va_list args; va_start(args, fmt); err("warning:", fmt, &args); va_end(args);}/*VARARGS0*/voidfatal(char *fmt,...){ va_list args; va_start(args, fmt); err("fatal error:", fmt, &args); va_end(args);#ifdef DEBUG abort();#endif exit(1);} :MPW:MPW Tools:Tools with Source:gawk:gawk-2.11:node.c
/* * node.c -- routines for node management *//* * Copyright (C) 1986, 1988, 1989 the Free Software Foundation, Inc. * * This file is part of GAWK, the GNU implementation of the * AWK Progamming Language. * * GAWK is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 1, or (at your option) * any later version. * * GAWK is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with GAWK; see the file COPYING. If not, write to * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */#include "awk.h"extern double strtod();/* * We can't dereference a variable until after we've given it its new value. * This variable points to the value we have to free up */NODE *deref;AWKNUMr_force_number(n)NODE *n;{ char *ptr;#ifdef DEBUG if (n == NULL) cant_happen(); if (n->type != Node_val) cant_happen(); if(n->flags == 0) cant_happen(); if (n->flags & NUM) return n->numbr;#endif if (n->stlen == 0) n->numbr = 0.0; else if (n->stlen == 1) { if (isdigit(n->stptr[0])) { n->numbr = n->stptr[0] - '0'; n->flags |= NUMERIC; } else n->numbr = 0.0; } else { errno = 0; n->numbr = (AWKNUM) strtod(n->stptr, &ptr); /* the following >= should be ==, but for SunOS 3.5 strtod() */ if (errno == 0 && ptr >= n->stptr + n->stlen) n->flags |= NUMERIC; } n->flags |= NUM; return n->numbr;}/* * the following lookup table is used as an optimization in force_string * (more complicated) variations on this theme didn't seem to pay off, but * systematic testing might be in order at some point */static char *values[] = { "0", "1", "2", "3", "4", "5", "6", "7", "8", "9",};#define NVAL (sizeof(values)/sizeof(values[0]))NODE *r_force_string(s)NODE *s;{ char buf[128]; char *fmt; long num; char *sp = buf;#ifdef DEBUG if (s == NULL) cant_happen(); if (s->type != Node_val) cant_happen(); if (s->flags & STR) return s; if (!(s->flags & NUM)) cant_happen(); if (s->stref != 0) cant_happen();#endif s->flags |= STR; /* should check validity of user supplied OFMT */ fmt = OFMT_node->var_value->stptr; if ((num = s->numbr) == s->numbr) { /* integral value */ if (num < NVAL && num >= 0) { sp = values[num]; s->stlen = 1; } else { (void) sprintf(sp, "%ld", num); s->stlen = strlen(sp); } } else { (void) sprintf(sp, fmt, s->numbr); s->stlen = strlen(sp); } s->stref = 1; emalloc(s->stptr, char *, s->stlen + 1, "force_string"); memcpy(s->stptr, sp, s->stlen+1); return s;}/* * Duplicate a node. (For strings, "duplicate" means crank up the * reference count.) */NODE *dupnode(n)NODE *n;{ register NODE *r; if (n->flags & TEMP) { n->flags &= ~TEMP; n->flags |= MALLOC; return n; } if ((n->flags & (MALLOC|STR)) == (MALLOC|STR)) { if (n->stref < 255) n->stref++; return n; } r = newnode(Node_illegal); *r = *n; r->flags &= ~(PERM|TEMP); r->flags |= MALLOC; if (n->type == Node_val && (n->flags & STR)) { r->stref = 1; emalloc(r->stptr, char *, r->stlen + 1, "dupnode"); memcpy(r->stptr, n->stptr, r->stlen+1); } return r;}/* this allocates a node with defined numbr */NODE *make_number(x)AWKNUM x;{ register NODE *r; r = newnode(Node_val); r->numbr = x; r->flags |= (NUM|NUMERIC); r->stref = 0; return r;}/* * This creates temporary nodes. They go away quite quickly, so don't use * them for anything important */NODE *tmp_number(x)AWKNUM x;{ NODE *r; r = make_number(x); r->flags |= TEMP; return r;}/* * Make a string node. */NODE *make_str_node(s, len, scan)char *s;int len;int scan;{ register NODE *r; char *pf; register char *pt; register int c; register char *end; r = newnode(Node_val); emalloc(r->stptr, char *, len + 1, s); memcpy(r->stptr, s, len); r->stptr[len] = '\0'; end = &(r->stptr[len]); if (scan) { /* scan for escape sequences */ for (pf = pt = r->stptr; pf < end;) { c = *pf++; if (c == '\\') { c = parse_escape(&pf); if (c < 0) cant_happen(); *pt++ = c; } else *pt++ = c; } len = pt - r->stptr; erealloc(r->stptr, char *, len + 1, "make_str_node"); r->stptr[len] = '\0'; r->flags |= PERM; } r->stlen = len; r->stref = 1; r->flags |= (STR|MALLOC); return r;}/* Read the warning under tmp_number */NODE *tmp_string(s, len)char *s;int len;{ register NODE *r; r = make_string(s, len); r->flags |= TEMP; return r;}#define NODECHUNK 100static NODE *nextfree = NULL;NODE *newnode(ty)NODETYPE ty;{ NODE *it; NODE *np;#ifdef MPROF emalloc(it, NODE *, sizeof(NODE), "newnode");#else if (nextfree == NULL) { /* get more nodes and initialize list */ emalloc(nextfree, NODE *, NODECHUNK * sizeof(NODE), "newnode"); for (np = nextfree; np < &nextfree[NODECHUNK - 1]; np++) np->nextp = np + 1; np->nextp = NULL; } /* get head of freelist */ it = nextfree; nextfree = nextfree->nextp;#endif it->type = ty; it->flags = MALLOC;#ifdef MEMDEBUG fprintf(stderr, "node: new: %0x\n", it);#endif return it;}voidfreenode(it)NODE *it;{#ifdef DEBUG NODE *nf;#endif#ifdef MEMDEBUG fprintf(stderr, "node: free: %0x\n", it);#endif#ifdef MPROF free((char *) it);#else#ifdef DEBUG for (nf = nextfree; nf; nf = nf->nextp) if (nf == it) fatal("attempt to free free node");#endif /* add it to head of freelist */ it->nextp = nextfree; nextfree = it;#endif}#ifdef DEBUGpf(){ NODE *nf = nextfree; while (nf != NULL) { fprintf(stderr, "%0x ", nf); nf = nf->nextp; }}#endifvoiddo_deref(){ if (deref == NULL) return; if (deref->flags & PERM) { deref = 0; return; } if ((deref->flags & MALLOC) || (deref->flags & TEMP)) { deref->flags &= ~TEMP; if (deref->flags & STR) { if (deref->stref > 1 && deref->stref != 255) { deref->stref--; deref = 0; return; } free(deref->stptr); } freenode(deref); } deref = 0;} :MPW:MPW Tools:Tools with Source:gawk:gawk-2.11:patchlevel.h
#define PATCHLEVEL 1 :MPW:MPW Tools:Tools with Source:gawk:gawk-2.11:pc.d:Makefile.pc
# Makefile for GNU Awk.## Copyright (C) 1986, 1988, 1989 the Free Software Foundation, Inc.# # This file is part of GAWK, the GNU implementation of the# AWK Progamming Language.# # GAWK is free software; you can redistribute it and/or modify# it under the terms of the GNU General Public License as published by# the Free Software Foundation; either version 1, or (at your option)# any later version.# # GAWK is distributed in the hope that it will be useful,# but WITHOUT ANY WARRANTY; without even the implied warranty of# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the# GNU General Public License for more details.# # You should have received a copy of the GNU General Public License# along with GAWK; see the file COPYING. If not, write to# the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.# User tunable macros# CFLAGS: options to the C compiler## -O optimize# -g include dbx/sdb info# -gg include gdb debugging info; only for GCC (deprecated)# -pg include new (gmon) profiling info# -p include old style profiling info (System V)## To port GAWK, examine and adjust the following flags carefully.# In addition, you will have to look at alloca below.# The intent (eventual) is to not penalize the most-standard-conforming# systems with a lot of #define's.## -DBCOPY_MISSING - bcopy() et al. are missing; will replace# with a #define'd memcpy() et al. -- use at# your own risk (should really use a memmove())# -DSPRINTF_INT - sprintf() returns int (most USG systems)# -DBLKSIZE_MISSING - st_blksize missing from stat() structure# (most USG systems)# -DBSDSTDIO - has a BSD internally-compatible stdio# -DDOPRNT_MISSING - lacks doprnt() routine# -DDUP2_MISSING - lacks dup2() system call (S5Rn, n < 4)# -DGCVT_MISSING - lacks gcvt() routine# -DGETOPT_MISSING - lacks getopt() routine# -DMEMCMP_MISSING - lacks memcmp() routine# -DMEMCPY_MISSING - lacks memcpy() routine# -DMEMSET_MISSING - lacks memset() routine# -DRANDOM_MISSING - lacks random() routine# -DSTRCASE_MISSING - lacks strcasecmp() routine# -DSTRCHR_MISSING - lacks strchr() and strrchr() routines# -DSTRERROR_MISSING - lacks (ANSI C) strerror() routine# -DSTRTOD_MISSING - lacks strtod() routine# -DTMPNAM_MISSING - lacks or deficient tmpnam() routine# -DVPRINTF_MISSING - lacks vprintf and associated routines# -DSIGTYPE=int - signal routines return int (default void)# Sun running SunOS 4.x# MISSING = -DSTRERROR_MISSING -DSTRCASE_MISSING# SGI Personal Iris (Sys V derived)# MISSING = -DSPRINTF_INT -DBLKSIZE_MISSING -DSTRERROR_MISSING -DRANDOM_MISSING# VAX running Ultrix 3.x# MISSING = -DSTRERROR_MISSING# A generic 4.2 BSD machine# (eliminate GETOPT_MISSING for 4.3 release)# (eliminate STRCASE_MISSING and TMPNAM_MISSING for Tahoe release)# MISSING = -DBSDSTDIO -DMEMCMP_MISSING -DMEMCPY_MISSING -DMEMSET_MISSING \# -DSTRERROR_MISSING -DSTRTOD_MISSING -DVPRINTF_MISSING \# -DSTRCASE_MISSING -DTMPNAM_MISSING \# -DGETOPT_MISSING -DSTRCHR_MISSING -DSIGTYPE=int# On Amdahl UTS, a SysVr2-derived system# MISSING = -DBCOPY_MISSING -DSPRINTF_INT -DRANDOM_MISSING -DSTRERROR_MISSING \# -DSTRCASE_MISSING -DDUP2_MISSING # -DBLKSIZE_MISSING ??????# Comment out the next line if you don't have gcc.# Also choose just one of -g and -O.# CC= gcc# for DOSCC= clPOPEN = popen.o# for DOS, most of the missing symbols are defined in MISSING.C in order to# get around the command line length limitationsMISSING = -DSPRINTF_INT -DBLKSIZE_MISSING -DBCOPY_MISSINGLINKFLAGS= /MAP /CO /FAR /PACKC /NOE /NOIG /st:0x1800# also give suffixes and explicit rule for DOS.SUFFIXES : .o .c.c.o: $(CC) -c $(CFLAGS) -Ipc.d -W2 -AL -Fo$*.o $< OPTIMIZE= -Od -ZiPROFILE= #-pgDEBUG= #-DDEBUG #-DMEMDEBUG #-DFUNC_TRACE #-DMPROFDEBUGGER= #-g -BstaticWARN= #-W -Wunused -Wimplicit -Wreturn-type -Wcomment # for gcc only# Parser to use on grammar -- if you don't have bison use the first one#PARSER = yaccPARSER = bison# ALLOCA# Set equal to alloca.o if your system is S5 and you don't have# alloca. Uncomment one of the rules below to make alloca.o from# either alloca.s or alloca.c.ALLOCA= #alloca.o## With the exception of the alloca rule referred to above, you shouldn't# need to customize this file below this point.#FLAGS= $(MISSING) $(DEBUG)CFLAGS= $(FLAGS) $(DEBUGGER) $(PROFILE) $(OPTIMIZE) $(WARN)# object filesO1 = main.o eval.o builtin.o msg.o debug.o io.o field.o array.o node.oO2 = version.o missing.o $(POPEN)AWKOBJS = $(O1) $(O2)# for unix# AWKTAB = awk.tab.o# for dosAWKTAB = awk_tab.oALLOBJS = $(AWKOBJS) $(AWKTAB)# GNUOBJS# GNU stuff that gawk uses as library routines.GNUOBJS= regex.o $(ALLOCA)# source and documentation filesSRC = main.c eval.c builtin.c msg.c \ debug.c io.c field.c array.c node.c missing.cALLSRC= $(SRC) awk.tab.cAWKSRC= awk.h awk.y $(ALLSRC) version.sh patchlevel.hGNUSRC = alloca.c alloca.s regex.c regex.hCOPIES = missing.d/dup2.c missing.d/gcvt.c missing.d/getopt.c \ missing.d/memcmp.c missing.d/memcpy.c missing.d/memset.c \ missing.d/random.c missing.d/strcase.c missing.d/strchr.c \ missing.d/strerror.c missing.d/strtod.c missing.d/tmpnam.c \ missing.d/vprintf.cSUPPORT = support/texindex.c support/texinfo.texDOCS= gawk.1 gawk.texinfoINFOFILES= gawk-info gawk-info-1 gawk-info-2 gawk-info-3 gawk-info-4 \ gawk-info-5 gawk-info-6 gawk.aux gawk.cp gawk.cps gawk.fn \ gawk.fns gawk.ky gawk.kys gawk.pg gawk.pgs gawk.toc \ gawk.tp gawk.tps gawk.vr gawk.vrsMISC = CHANGES COPYING FUTURES Makefile PROBLEMS READMEPCSTUFF= pc.d/Makefile.pc pc.d/popen.c pc.d/popen.hALLDOC= gawk.dvi $(INFOFILES)ALLFILES= $(AWKSRC) $(GNUSRC) $(COPIES) $(MISC) $(DOCS) $(ALLDOC) $(PCSTUFF) $(SUPPORT)# Release of gawk. There can be no leading or trailing white space here!REL=2.11# for unix# GAWK = gawk# for DOSGAWK = gawk.exe$(GAWK) : $(ALLOBJS) $(GNUOBJS) names.lnk link @names.lnk#GNULIB = ..\lib\lgnu.lib GNULIB = names.lnk : makefile echo $(O1) + > $@ echo $(O2) + >> $@ echo $(AWKTAB) + >> $@ echo $(GNUOBJS) >> $@ echo $(GAWK) >> $@ echo gawk.map >> $@ echo $(GNULIB) $(LINKFLAGS) >> $@popen.o : pc.d\popen.c $(CC) -c $(CFLAGS) -Ipc.d -W2 -AL -Fo$*.o pc.d\popen.c# rules to build gawk#$(GAWK) : $(ALLOBJS) $(GNUOBJS)# $(CC) -o gawk $(CFLAGS) $(ALLOBJS) $(GNUOBJS) -lm$(AWKOBJS): awk.hmain.o: patchlevel.h#awk.tab.o: awk.h awk.tab.c##awk.tab.c: awk.y# $(PARSER) -v awk.y# -mv -f y.tab.c awk.tab.c# for dosawk_tab.o : awk.y awk.h bison -y awk.y $(CC) -c $(CFLAGS) -Ipc.d -W2 -AL -Fo$@ y_tab.c @-rm y_tab.cversion.c: version.sh sh version.sh $(REL) > version.c# Alloca: uncomment this if your system (notably System V boxen)# does not have alloca in /lib/libc.a##alloca.o: alloca.s# /lib/cpp < alloca.s | sed '/^#/d' > t.s# as t.s -o alloca.o# rm t.s# If your machine is not supported by the assembly version of alloca.s,# use the C version instead. This uses the default rules to make alloca.o.##alloca.o: alloca.c# auxiliary rules for release maintenancelint: $(ALLSRC) lint -hcbax $(FLAGS) $(ALLSRC)xref: cxref -c $(FLAGS) $(ALLSRC) | grep -v ' /' >xrefclean: rm -f gawk *.o core awk.output awk.tab.c gmon.out make.out version.cclobber: clean rm -f $(ALLDOC) gawk.loggawk.dvi: gawk.texinfo tex gawk.texinfo ; texindex gawk.?? tex gawk.texinfo ; texindex gawk.?? tex gawk.texinfo$(INFOFILES): gawk.texinfo makeinfo gawk.texinfosrcrelease: $(AWKSRC) $(GNUSRC) $(DOCS) $(MISC) $(COPIES) $(PCSTUFF) $(SUPPORT) -mkdir gawk-$(REL) cp -p $(AWKSRC) $(GNUSRC) $(DOCS) $(MISC) gawk-$(REL) -mkdir gawk-$(REL)/missing.d cp -p $(COPIES) gawk-$(REL)/missing.d -mkdir gawk-$(REL)/pc.d cp -p $(PCSTUFF) gawk-$(REL)/pc.d -mkdir gawk-$(REL)/support cp -p $(SUPPORT) gawk-$(REL)/support tar -cf - gawk-$(REL) | compress > gawk-$(REL).tar.Zdocrelease: $(ALLDOC) -mkdir gawk-$(REL)-doc cp -p $(INFOFILES) gawk.dvi gawk-$(REL)-doc nroff -man gawk.1 > gawk-$(REL)-doc/gawk.1.pr tar -cf - gawk-$(REL)-doc | compress > gawk-doc-$(REL).tar.Zpsrelease: docrelease -mkdir gawk-postscript dvi2ps gawk.dvi > gawk-postscript/gawk.postscript psroff -t -man gawk.1 > gawk-postscript/gawk.1.ps tar -cf - gawk-postscript | compress > gawk.postscript.tar.Zrelease: srcrelease docrelease psrelease rm -fr gawk-postscript gawk-$(REL) gawk-$(REL)-docdiff: for i in RCS/*; do rcsdiff -c -b $$i > `basename $$i ,v`.diff; done :MPW:MPW Tools:Tools with Source:gawk:gawk-2.11:pc.d:popen.c
#include <stdio.h>#include "popen.h"#include <io.h>#include <string.h>#include <process.h>static char template[] = "piXXXXXX";typedef enum { unopened = 0, reading, writing } pipemode;staticstruct { char *command; char *name; pipemode pmode;} pipes[_NFILE];FILE *popen( char *command, char *mode ) { FILE *current; char *name; int cur; pipemode curmode; /* ** decide on mode. */ if(strcmp(mode,"r") == 0) curmode = reading; else if(strcmp(mode,"w") == 0)curmode = writing; else return NULL; /* ** get a name to use. */ if((name = tempnam(".","pip"))==NULL) return NULL; /* ** If we're reading, just call system to get a file filled with ** output. */ if(curmode == reading) { char cmd[256]; sprintf(cmd,"%s > %s",command,name); system(cmd); if((current = fopen(name,"r")) == NULL) return NULL; } else { if((current = fopen(name,"w")) == NULL) return NULL; } cur = fileno(current); pipes[cur].name = name; pipes[cur].pmode = curmode; pipes[cur].command = strdup(command); return current;}intpclose( FILE * current) { int cur = fileno(current),rval; /* ** check for an open file. */ if(pipes[cur].pmode == unopened) return -1; if(pipes[cur].pmode == reading) { /* ** input pipes are just files we're done with. */ rval = fclose(current); unlink(pipes[cur].name); } else { /* ** output pipes are temporary files we have ** to cram down the throats of programs. */ char command[256]; fclose(current); sprintf(command,"%s < %s",pipes[cur].command,pipes[cur].name); rval = system(command); unlink(pipes[cur].name); } /* ** clean up current pipe. */ pipes[cur].pmode = unopened; free(pipes[cur].name); free(pipes[cur].command); return rval;} :MPW:MPW Tools:Tools with Source:gawk:gawk-2.11:pc.d:popen.h
/*** popen.h -- prototypes for pipe functions*/#if !defined(FILE)#include <stdio.h>#endifextern FILE *popen( char *, char * ); :MPW:MPW Tools:Tools with Source:gawk:gawk-2.11:Prototypes.h
/* * Copyright (C) 1986, 1988, 1989 the Free Software Foundation, Inc. * * This file is part of GAWK, the GNU implementation of the * AWK Progamming Language. * * GAWK is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 1, or (at your option) * any later version. * * GAWK is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with GAWK; see the file COPYING. If not, write to * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ #if defined (X3J11) || defined (THINK_C)typedef void *pointer; /* generic pointer type */#elsetypedef char *pointer; /* generic pointer type */#endif/* Protoypes grabbed from file** "alloca.c"** 1990 Sep 5 (Wed) 20:40:48*/void find_stack_direction(void); pointer alloca(unsigned size); /* # bytes to allocate *//* Protoypes grabbed from file** "awk.tab.c"** 1990 Sep 6 (Thu) 20:38:04*/int yyparse(void); void yyerror(char *,...); int yylex(void); FILE * pathopen(char *file); NODE * node_common(NODETYPE op); NODE * node(NODE *left, NODETYPE op, NODE *right); NODE * snode(NODE *subn, NODETYPE op, NODE *(*procp)()); NODE * mkrangenode(NODE *cpair); NODE * make_for_loop(NODE *init, NODE *cond, NODE *incr); NODE * install(NODE **table, char *name, NODE *value); NODE * lookup(NODE **table, char *name); int hashf(char *name, int len, int hashsize); NODE * append_right(NODE *list, NODE *new); void func_install(NODE *params, NODE *def); void pop_var(NODE *np, int freeit); void pop_params(NODE *params); NODE * make_param(char *name); NODE * variable(char *name); /* Protoypes grabbed from file** "array.c"** 1990 Aug 5 (Sun) 22:00:19*/NODE * concat_exp(NODE *tree); void assoc_clear(NODE *symbol); int hash_calc(NODE *subs); NODE * assoc_find(NODE *symbol, NODE *subs, int hash1); int in_array(NODE *symbol, NODE *subs); NODE ** assoc_lookup(NODE *symbol, NODE *subs); void do_delete(NODE *symbol, NODE *tree); struct search * assoc_scan(NODE *symbol); struct search * assoc_next(struct search *lookat); /* Protoypes grabbed from file** "builtin.c"** 1990 Jul 29 (Sun) 21:33:56*/NODE * do_exp(NODE *tree); NODE * do_index(NODE *tree); NODE * do_int(NODE *tree); NODE * do_length(NODE *tree); NODE * do_log(NODE *tree); NODE * do_sprintf(NODE *tree); void do_printf(NODE *tree); NODE * do_sqrt(NODE *tree); NODE * do_substr(NODE *tree); NODE * do_system(NODE *tree); void do_print(NODE *tree); NODE * do_tolower(NODE *tree); NODE * do_toupper(NODE *tree); void get_one(NODE *tree, NODE **res); void get_two(NODE *tree, NODE **res1, NODE **res2); int get_three(NODE *tree, NODE **res1, NODE **res2, NODE **res3); int a_get_three(NODE *tree, NODE **res1, NODE **res2, NODE **res3); void print_simple(NODE *tree, FILE *fp); NODE * do_atan2(NODE *tree); NODE * do_sin(NODE *tree); NODE * do_cos(NODE *tree); NODE * do_rand(NODE *tree); NODE * do_srand(NODE *tree); NODE * do_match(NODE *tree); NODE * sub_common(NODE *tree, int global); NODE * do_gsub(NODE *tree); NODE * do_sub(NODE *tree); /* Protoypes grabbed from file** "debug.c"** 1990 Aug 18 (Sat) 13:22:48*/ ptree(NODE *n); pt(void); print_parse_tree(NODE *ptr); dump_vars(void); dump_fields(void); print_debug(char *str, int n); print_a_node(NODE *ptr); print_maybe_semi(NODE *ptr); deal_with_curls(NODE *ptr); NODE * do_prvars(void); NODE * do_bp(void); void do_free(char *s); /* Protoypes grabbed from file** "eval.c"** 1990 Jul 29 (Sun) 21:33:54*/int interpret(NODE *tree); NODE * r_tree_eval(NODE *tree); void assign_number(NODE **ptr, AWKNUM value); int eval_condition(NODE *tree); int cmp_nodes(NODE *t1, NODE *t2); NODE * op_assign(NODE *tree); NODE * func_call(NODE *name, /* name is a Node_val giving function name */ NODE *arg_list); /* Node_expression_list of calling args. */NODE ** get_lhs(NODE *ptr, int assign); /* this is being called for the LHS of an assign. */NODE * match_op(NODE *tree); /* Protoypes grabbed from file** "field.c"** 1990 Jul 29 (Sun) 21:34:01*/void init_fields(void); void set_field(int num, char *str, int len, NODE *dummy); void rebuild_record(void); void set_record(char *buf, int cnt); NODE ** get_field(int num, int assign); int parse_fields(int up_to, char **buf, int len, char *fs, void (*set)(), NODE *n); int re_split(char *buf, int len, char *fs, struct re_registers *reregsp); NODE * do_split(NODE *tree); char * get_fs(void); void set_element(int num, char *s, int len, NODE *n); /* Protoypes grabbed from file** "gnufuncts.c"** 1990 Sep 5 (Wed) 20:49:10*/void bzero(void *p, int n); FILE * popen(char *s, char *mode); pclose(FILE *fp); int bcmp(char *d, char *d2, int mcnt); char * index(char *s, char c); int pipe(int fildes[2]); int fork(void); int wait(void *); int dup2(int old, int new); pointer xmalloc(unsigned int n); /* Protoypes grabbed from file** "io.c"** 1990 Aug 28 (Tue) 21:10:46*/IOBUF * nextfile(void); IOBUF * iop_alloc(int fd); void do_input(void); int iop_close(IOBUF *iop); int inrec(IOBUF *iop); void do_file(IOBUF *iop); int get_rs(void); struct redirect * redirect(NODE *tree, int *errflg); void close_one(void); NODE * do_close(NODE *tree); int close_redir(struct redirect *rp); int flush_io(void); int close_io(void); int devopen(char *name, char *mode); IOBUF * gawchar *cmd, struct redirect *rp); int gawk_pclose(struct redirect *rp); IOBUF * gawk_popen(char *cmd, struct redirect *rp); int gawk_pclose(struct redirect *rp); int get_a_record(char **res, IOBUF *iop); NODE * do_getline(NODE *tree); /* Protoypes grabbed from file** "main.c"** 1990 Sep 3 (Mon) 18:29:41*/int main(int argc, char **argv); void usage(void); struct re_pattern_buffer * make_regexp(NODE *s, int ignorecase); struct re_pattern_buffer * mk_re_parse(char *s, int ignorecase); void copyleft(void); void set_fs(char *str); void init_args(int argc0, int argc, char *argv0, char **argv); void init_vars(void); NODE * spc_var(char *name, NODE *value); void pre_assign(char *v); SIGTYPE catchsig(int sig, int code); /* Protoypes grabbed from file** "msg.c"** 1990 Jul 29 (Sun) 21:33:58*/void err(char *s, char *msg, va_list *argp); /* Protoypes grabbed from file** "node.c"** 1990 Jul 29 (Sun) 21:34:01*/AWKNUM r_force_number(NODE *n); NODE * r_force_string(NODE *s); NODE * dupnode(NODE *n); NODE * make_number(AWKNUM x); NODE * tmp_number(AWKNUM x); NODE * make_str_node(char *s, int len, int scan); NODE * tmp_string(char *s, int len); NODE * newnode(NODETYPE ty); void freenode(NODE *it); pf(void); void do_deref(void); /* Protoypes grabbed from file** "regex.c"** 1990 Sep 2 (Sun) 21:54:54*/void init_syntax_once(void); int re_set_syntax( int syntax); char * re_compile_pattern(char *pattern, int size, struct re_pattern_buffer *bufp); int store_jump(char *from, char opcode, char *to); int insert_jump(char op, char *from, char *to, char *current_end); void re_compile_fastmap(struct re_pattern_buffer *bufp); int re_search(struct re_pattern_buffer *pbufp, char *string, int size, int startpos, int range, struct re_registers *regs); int re_search_2(struct re_pattern_buffer *pbufp, char *string1, int size1, char *string2, int size2, int startpos, int range, struct re_registers *regs, int mstop); int re_match(struct re_pattern_buffer *pbufp, char *string, int size, int pos, struct re_registers *regs); int re_match_2(struct re_pattern_buffer *pbufp, unsigned char *string1, int size1, unsigned char *string2, int size2, int pos, struct re_registers *regs, int mstop); int bcmp_translate(unsigned char *s1, unsigned char *s2, int len, unsigned char *translate); char * re_comp(char *s); int re_exec(char *s); main(int argc, char **argv); print_buf(struct re_pattern_buffer *bufp); printchar(char c); /* Protoypes grabbed from file** "gcvt.c"** 1990 Jul 29 (Sun) 21:34:33*/char * gcvt(double value, int digits, char *buff); /* Protoypes grabbed from file** "getopt.c"** 1990 Aug 18 (Sat) 13:19:18*/int getopt(int argc, char **argv, char *opts); /* Protoypes grabbed from file** "random.c"** 1990 Jul 29 (Sun) 21:34:35*/ srandom(unsigned x); char * initstate(unsigned seed, char *arg_state, int n); char * setstate(char *arg_state); long random(void); /* Protoypes grabbed from file** "strcase.c"** 1990 Aug 18 (Sat) 13:21:27*/ strcasecmp(char *s1, char *s2); strncasecmp(char *s1, char *s2, int n); /* Protoypes grabbed from file** "strerror.c"** 1990 Jul 29 (Sun) 21:34:36*/char * strerror(int n); /* Protoypes grabbed from file** "strtod.c"** 1990 Jul 29 (Sun) 21:34:37*/double strtod(char *s, char **ptr); main(int argc, char **argv); /* Protoypes grabbed from file** "tmpnam.c"** 1990 Jul 29 (Sun) 21:34:37*/char * tmpnam(char *tmp); /* Protoypes grabbed from file** "vprintf.c"** 1990 Jul 29 (Sun) 21:34:37*/int vsprintf(char *str, char *fmt, va_list ap); int vfprintf(FILE *iop, char *fmt, va_list ap); int vprintf(char *fmt, va_list ap); /* Protoypes grabbed from file** "msg.c"** 1990 Jul 29 (Sun) 21:33:58*/void msg(char *,...); :MPW:MPW Tools:Tools with Source:gawk:gawk-2.11:regex.c
/* Extended regular expression matching and search. Copyright (C) 1985 Free Software Foundation, Inc. NO WARRANTY BECAUSE THIS PROGRAM IS LICENSED FREE OF CHARGE, WE PROVIDE ABSOLUTELYNO WARRANTY, TO THE EXTENT PERMITTED BY APPLICABLE STATE LAW. EXCEPTWHEN OTHERWISE STATED IN WRITING, FREE SOFTWARE FOUNDATION, INC,RICHARD M. STALLMAN AND/OR OTHER PARTIES PROVIDE THIS PROGRAM "AS IS"WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING,BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY ANDFITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITYAND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVEDEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR ORCORRECTION. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW WILL RICHARD M.STALLMAN, THE FREE SOFTWARE FOUNDATION, INC., AND/OR ANY OTHER PARTYWHO MAY MODIFY AND REDISTRIBUTE THIS PROGRAM AS PERMITTED BELOW, BELIABLE TO YOU FOR DAMAGES, INCLUDING ANY LOST PROFITS, LOST MONIES, OROTHER SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THEUSE OR INABILITY TO USE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA ORDATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY THIRD PARTIES ORA FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS) THISPROGRAM, EVEN IF YOU HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCHDAMAGES, OR FOR ANY CLAIM BY ANY OTHER PARTY. GENERAL PUBLIC LICENSE TO COPY 1. You may copy and distribute verbatim copies of this source fileas you receive it, in any medium, provided that you conspicuously andappropriately publish on each copy a valid copyright notice "Copyright(C) 1985 Free Software Foundation, Inc."; and include following thecopyright notice a verbatim copy of the above disclaimer of warrantyand of this License. You may charge a distribution fee for thephysical act of transferring a copy. 2. You may modify your copy or copies of this source file orany portion of it, and copy and distribute such modifications underthe terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains or is a derivative of this program or any part thereof, to be licensed at no charge to all third parties on terms identical to those contained in this License Agreement (except that you may choose to grant more extensive warranty protection to some or all third parties, at your option). c) You may charge a distribution fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee.Mere aggregation of another unrelated program with this program (or itsderivative) on a volume of a storage or distribution medium does not bringthe other program under the scope of these terms. 3. You may copy and distribute this program (or a portion or derivativeof it, under Paragraph 2) in object code or executable form under the termsof Paragraphs 1 and 2 above provided that you also do one of the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal shipping charge) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.)For an executable file, complete source code means all the source code forall modules it contains; but, as a special exception, it need not includesource code for modules which are standard libraries that accompany theoperating system on which the executable file runs. 4. You may not copy, sublicense, distribute or transfer this programexcept as expressly provided under this License Agreement. Any attemptotherwise to copy, sublicense, distribute or transfer this program is void andyour rights to use the program under this License agreement shall beautomatically terminated. However, parties who have received computersoftware programs from you with this License Agreement will not havetheir licenses terminated so long as such parties remain in full compliance. 5. If you wish to incorporate parts of this program into other freeprograms whose distribution conditions are different, write to the FreeSoftware Foundation at 675 Mass Ave, Cambridge, MA 02139. We have not yetworked out a simple rule that can be stated here, but we will often permitthis. We will be guided by the two goals of preserving the free status ofall derivatives of our free software and of promoting the sharing and reuse ofsoftware.In other words, you are welcome to use, share and improve this program.You are forbidden to forbid anyone else to use, share and improvewhat you give them. Help stamp out software-hoarding! */#ifdef MSDOS#include <malloc.h>#else#include <stdio.h>#include <stdlib.h>#include <string.h>#endif#if defined(MSDOS) || defined(THINK_C)static void init_syntax_once(void );extern int re_set_syntax(int syntax);extern char *re_compile_pattern(char *pattern,int size, struct re_pattern_buffer *bufp);static int store_jump(char *from,char opcode,char *to);static int insert_jump(char op,char *from,char *to,char *current_end);extern void re_compile_fastmap(struct re_pattern_buffer *bufp);extern int re_search(struct re_pattern_buffer *pbufp,char *string, int size,int startpos,int range, struct re_registers *regs);extern int re_search_2(struct re_pattern_buffer *pbufp,char *string1, int size1,char *string2,int size2,int startpos, int range,struct re_registers *regs,int mstop);extern int re_match(struct re_pattern_buffer *pbufp,char *string, int size,int pos,struct re_registers *regs);extern int re_match_2(struct re_pattern_buffer *pbufp, unsigned char *string1,int size1, unsigned char *string2,int size2,int pos, struct re_registers *regs,int mstop);static int bcmp_translate(unsigned char *s1,unsigned char *s2, int len,unsigned char *translate);extern char *re_comp(char *s);extern int re_exec(char *s);#if defined (X3J11) || defined (THINK_C)typedef void *pointer; /* generic pointer type */#elsetypedef char *pointer; /* generic pointer type */#endif/* Protoypes grabbed from file** "alloca.c"** 1990 Sep 5 (Wed) 20:40:48*/void find_stack_direction(void); pointer alloca(unsigned size); /* # bytes to allocate */#endif/* To test, compile with -Dtest. This Dtestable feature turns this into a self-contained program which reads a pattern, describes how it compiles, then reads a string and searches for it. */#ifdef emacs/* The `emacs' switch turns on certain special matching commands that make sense only in emacs. */#include "config.h"#include "lisp.h"#include "buffer.h"#include "syntax.h"#else /* not emacs */#ifdef THINK_C#include "config.h"#endif#ifdef BCOPY_MISSING#define bcopy(s,d,n) memcpy((d),(s),(n))#define bcmp(s1,s2,n) memcmp((s1),(s2),(n))#define bzero(s,n) memset((s),0,(n))#elsevoid bcopy();int bcmp();void bzero();#endif/* Make alloca work the best possible way. */#ifdef __GNUC__#define alloca __builtin_alloca#else#ifdef sparc#include <alloca.h>#endif#endif/* * Define the syntax stuff, so we can do the \<...\> things. */#ifndef Sword /* must be non-zero in some of the tests below... */#define Sword 1#endif#define SYNTAX(c) re_syntax_table[c]#ifdef SYNTAX_TABLEchar *re_syntax_table;#elsestatic char re_syntax_table[256];static voidinit_syntax_once (){ register int c; static int done = 0; if (done) return; bzero (re_syntax_table, sizeof re_syntax_table); for (c = 'a'; c <= 'z'; c++) re_syntax_table[c] = Sword; for (c = 'A'; c <= 'Z'; c++) re_syntax_table[c] = Sword; for (c = '0'; c <= '9'; c++) re_syntax_table[c] = Sword; done = 1;}#endif /* SYNTAX_TABLE */#endif /* not emacs */#include "regex.h"/* Number of failure points to allocate space for initially, when matching. If this number is exceeded, more space is allocated, so it is not a hard limit. */#ifndef NFAILURES#define NFAILURES 80#endif /* NFAILURES *//* width of a byte in bits */#define BYTEWIDTH 8#ifndef SIGN_EXTEND_CHAR#define SIGN_EXTEND_CHAR(x) (x)#endif static int obscure_syntax = 0;/* Specify the precise syntax of regexp for compilation. This provides for compatibility for various utilities which historically have different, incompatible syntaxes. The argument SYNTAX is a bit-mask containing the two bits RE_NO_BK_PARENS and RE_NO_BK_VBAR. */intre_set_syntax (syntax){ int ret; ret = obscure_syntax; obscure_syntax = syntax; return ret;} /* re_compile_pattern takes a regular-expression string and converts it into a buffer full of byte commands for matching. PATTERN is the address of the pattern string SIZE is the length of it. BUFP is a struct re_pattern_buffer * which points to the info on where to store the byte commands. This structure contains a char * which points to the actual space, which should have been obtained with malloc. re_compile_pattern may use realloc to grow the buffer space. The number of bytes of commands can be found out by looking in the struct re_pattern_buffer that bufp pointed to, after re_compile_pattern returns.*/#define PATPUSH(ch) (*b++ = (char) (ch))#define PATFETCH(c) \ {if (p == pend) goto end_of_pattern; \ c = * (unsigned char *) p++; \ if (translate) c = translate[c]; }#define PATFETCH_RAW(c) \ {if (p == pend) goto end_of_pattern; \ c = * (unsigned char *) p++; }#define PATUNFETCH p--#ifdef MSDOS#define MaxAllocation (1<<14)#else#define MaxAllocation (1<<16)#endif#define EXTEND_BUFFER \ { char *old_buffer = bufp->buffer; \ if (bufp->allocated == MaxAllocation) goto too_big; \ bufp->allocated *= 2; \ if (bufp->allocated > MaxAllocation) bufp->allocated = MaxAllocation; \ if (!(bufp->buffer = (char *) realloc (bufp->buffer, bufp->allocated))) \ goto memory_exhausted; \ c = bufp->buffer - old_buffer; \ b += c; \ if (fixup_jump) \ fixup_jump += c; \ if (laststart) \ laststart += c; \ begalt += c; \ if (pending_exact) \ pending_exact += c; \ }#ifdef NEVER#define EXTEND_BUFFER \ { unsigned b_off = b - bufp->buffer, \ f_off, l_off, p_off, \ beg_off = begalt - bufp->buffer; \ if (fixup_jump) \ f_off = fixup_jump - bufp->buffer; \ if (laststart) \ l_off = laststart - bufp->buffer; \ if (pending_exact) \ p_off = pending_exact - bufp->buffer; \ if (bufp->allocated == MaxAllocation) goto too_big; \ bufp->allocated *= 2; \ if (bufp->allocated > MaxAllocation) bufp->allocated = MaxAllocation; \ if (!(bufp->buffer = (char *) realloc (bufp->buffer, bufp->allocated))) \ goto memory_exhausted; \ b = bufp->buffer + b_off; \ if (fixup_jump) \ fixup_jump = bufp->buffer + f_off; \ if (laststart) \ laststart = bufp->buffer + l_off; \ begalt = bufp->buffer + beg_off; \ if (pending_exact) \ pending_exact = bufp->buffer + p_off; \ }#endifstatic int store_jump (), insert_jump ();char *re_compile_pattern (pattern, size, bufp) char *pattern; int size; struct re_pattern_buffer *bufp;{ register char *b = bufp->buffer; register char *p = pattern; char *pend = pattern + size; register unsigned c, c1; char *p1; unsigned char *translate = (unsigned char *) bufp->translate; /* address of the count-byte of the most recently inserted "exactn" command. This makes it possible to tell whether a new exact-match character can be added to that command or requires a new "exactn" command. */ char *pending_exact = 0; /* address of the place where a forward-jump should go to the end of the containing expression. Each alternative of an "or", except the last, ends with a forward-jump of this sort. */ char *fixup_jump = 0; /* address of start of the most recently finished expression. This tells postfix * where to find the start of its operand. */ char *laststart = 0; /* In processing a repeat, 1 means zero matches is allowed */ char zero_times_ok; /* In processing a repeat, 1 means many matches is allowed */ char many_times_ok; /* address of beginning of regexp, or inside of last \( */ char *begalt = b; /* Stack of information saved by \( and restored by \). Four stack elements are pushed by each \(: First, the value of b. Second, the value of fixup_jump. Third, the value of regnum. Fourth, the value of begalt. */ int stackb[40]; int *stackp = stackb; int *stacke = stackb + 40; int *stackt; /* Counts \('s as they are encountered. Remembered for the matching \), where it becomes the "register number" to put in the stop_memory command */ int regnum = 1; bufp->fastmap_accurate = 0;#ifndef emacs#ifndef SYNTAX_TABLE /* * Initialize the syntax table. */ init_syntax_once();#endif#endif if (bufp->allocated == 0) { bufp->allocated = 28; if (bufp->buffer) /* EXTEND_BUFFER loses when bufp->allocated is 0 */ bufp->buffer = (char *) realloc (bufp->buffer, 28); else /* Caller did not allocate a buffer. Do it for him */ bufp->buffer = (char *) malloc (28); if (!bufp->buffer) goto memory_exhausted; begalt = b = bufp->buffer; } while (p != pend) { if (b - bufp->buffer > bufp->allocated - 10) /* Note that EXTEND_BUFFER clobbers c */ EXTEND_BUFFER; PATFETCH (c); switch (c) { case '$': if (obscure_syntax & RE_TIGHT_VBAR) { if (! (obscure_syntax & RE_CONTEXT_INDEP_OPS) && p != pend) goto normal_char; /* Make operand of last vbar end before this `$'. */ if (fixup_jump) store_jump (fixup_jump, jump, b); fixup_jump = 0; PATPUSH (endline); break; } /* $ means succeed if at end of line, but only in special contexts. If randomly in the middle of a pattern, it is a normal character. */ if (p == pend || *p == '\n' || (obscure_syntax & RE_CONTEXT_INDEP_OPS) || (obscure_syntax & RE_NO_BK_PARENS ? *p == ')' : *p == '\\' && p[1] == ')') || (obscure_syntax & RE_NO_BK_VBAR ? *p == '|' : *p == '\\' && p[1] == '|')) { PATPUSH (endline); break; } goto normal_char; case '^': /* ^ means succeed if at beg of line, but only if no preceding pattern. */ if (laststart && p[-2] != '\n' && ! (obscure_syntax & RE_CONTEXT_INDEP_OPS)) goto normal_char; if (obscure_syntax & RE_TIGHT_VBAR) { if (p != pattern + 1 && ! (obscure_syntax & RE_CONTEXT_INDEP_OPS)) goto normal_char; PATPUSH (begline); begalt = b; } else PATPUSH (begline); break; case '+': case '?': if (obscure_syntax & RE_BK_PLUS_QM) goto normal_char; handle_plus: case '*': /* If there is no previous pattern, char not special. */ if (!laststart && ! (obscure_syntax & RE_CONTEXT_INDEP_OPS)) goto normal_char; /* If there is a sequence of repetition chars, collaps
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:gawk:gawk-2.11:regex.c
+++++ Continued from previous card +++++
e it down to equivalent to just one. */ zero_times_ok = 0; many_times_ok = 0; while (1) { zero_times_ok |= c != '+'; many_times_ok |= c != '?'; if (p == pend) break; PATFETCH (c); if (c == '*') ; else if (!(obscure_syntax & RE_BK_PLUS_QM) && (c == '+' || c == '?')) ; else if ((obscure_syntax & RE_BK_PLUS_QM) && c == '\\') { int c1; PATFETCH (c1); if (!(c1 == '+' || c1 == '?')) { PATUNFETCH; PATUNFETCH; break; } c = c1; } else { PATUNFETCH; break; } } /* Star, etc. applied to an empty pattern is equivalent to an empty pattern. */ if (!laststart) break; /* Now we know whether 0 matches is allowed, and whether 2 or more matches is allowed. */ if (many_times_ok) { /* If more than one repetition is allowed, put in a backward jump at the end. */ store_jump (b, maybe_finalize_jump, laststart - 3); b += 3; } insert_jump (on_failure_jump, laststart, b + 3, b); pending_exact = 0; b += 3; if (!zero_times_ok) { /* At least one repetition required: insert before the loop a skip over the initial on-failure-jump instruction */ insert_jump (dummy_failure_jump, laststart, laststart + 6, b); b += 3; } break; case '.': laststart = b; PATPUSH (anychar); break; case '[': while (b - bufp->buffer > bufp->allocated - 3 - (1 << BYTEWIDTH) / BYTEWIDTH) /* Note that EXTEND_BUFFER clobbers c */ EXTEND_BUFFER; laststart = b; if (*p == '^') PATPUSH (charset_not), p++; else PATPUSH (charset); p1 = p; PATPUSH ((1 << BYTEWIDTH) / BYTEWIDTH); /* Clear the whole map */ bzero (b, (1 << BYTEWIDTH) / BYTEWIDTH); /* Read in characters and ranges, setting map bits */ while (1) { PATFETCH (c); /* If awk, \ escapes characters inside [...]. */ if ((obscure_syntax & RE_AWK_CLASS_HACK) && c == '\\') { PATFETCH(c1); b[c1 / BYTEWIDTH] |= 1 << (c1 % BYTEWIDTH); continue; } if (c == ']' && p != p1 + 1) break; if (*p == '-' && p[1] != ']') { PATFETCH (c1); PATFETCH (c1); while (c <= c1) b[c / BYTEWIDTH] |= 1 << (c % BYTEWIDTH), c++; } else { b[c / BYTEWIDTH] |= 1 << (c % BYTEWIDTH); } } /* Discard any bitmap bytes that are all 0 at the end of the map. Decrement the map-length byte too. */ while ((int) b[-1] > 0 && b[b[-1] - 1] == 0) b[-1]--; b += b[-1]; break; case '(': if (! (obscure_syntax & RE_NO_BK_PARENS)) goto normal_char; else goto handle_open; case ')': if (! (obscure_syntax & RE_NO_BK_PARENS)) goto normal_char; else goto handle_close; case '\n': if (! (obscure_syntax & RE_NEWLINE_OR)) goto normal_char; else goto handle_bar; case '|': if (! (obscure_syntax & RE_NO_BK_VBAR)) goto normal_char; else goto handle_bar; case '\\': if (p == pend) goto invalid_pattern; PATFETCH_RAW (c); switch (c) { case '(': if (obscure_syntax & RE_NO_BK_PARENS) goto normal_backsl; handle_open: if (stackp == stacke) goto nesting_too_deep; if (regnum < RE_NREGS) { PATPUSH (start_memory); PATPUSH (regnum); } *stackp++ = b - bufp->buffer; *stackp++ = fixup_jump ? fixup_jump - bufp->buffer + 1 : 0; *stackp++ = regnum++; *stackp++ = begalt - bufp->buffer; fixup_jump = 0; laststart = 0; begalt = b; break; case ')': if (obscure_syntax & RE_NO_BK_PARENS) goto normal_backsl; handle_close: if (stackp == stackb) goto unmatched_close; begalt = *--stackp + bufp->buffer; if (fixup_jump) store_jump (fixup_jump, jump, b); if (stackp[-1] < RE_NREGS) { PATPUSH (stop_memory); PATPUSH (stackp[-1]); } stackp -= 2; fixup_jump = 0; if (*stackp) fixup_jump = *stackp + bufp->buffer - 1; laststart = *--stackp + bufp->buffer; break; case '|': if (obscure_syntax & RE_NO_BK_VBAR) goto normal_backsl; handle_bar: insert_jump (on_failure_jump, begalt, b + 6, b); pending_exact = 0; b += 3; if (fixup_jump) store_jump (fixup_jump, jump, b); fixup_jump = b; b += 3; laststart = 0; begalt = b; break;#ifdef emacs case '=': PATPUSH (at_dot); break; case 's': laststart = b; PATPUSH (syntaxspec); PATFETCH (c); PATPUSH (syntax_spec_code[c]); break; case 'S': laststart = b; PATPUSH (notsyntaxspec); PATFETCH (c); PATPUSH (syntax_spec_code[c]); break;#endif /* emacs */ case 'w': laststart = b; PATPUSH (wordchar); break; case 'W': laststart = b; PATPUSH (notwordchar); break; case '<': PATPUSH (wordbeg); break; case '>': PATPUSH (wordend); break; case 'b': PATPUSH (wordbound); break; case 'B': PATPUSH (notwordbound); break; case '`': PATPUSH (begbuf); break; case '\'': PATPUSH (endbuf); break; case '1': case '2': case '3': case '4': : case '6': case '7': case '8': case '9': c1 = c - '0'; if (c1 >= regnum) goto normal_char; for (stackt = stackp - 2; stackt > stackb; stackt -= 4) if (*stackt == c1) goto normal_char; laststart = b; PATPUSH (duplicate); PATPUSH (c1); break; case '+': case '?': if (obscure_syntax & RE_BK_PLUS_QM) goto handle_plus; default: normal_backsl: /* You might think it would be useful for \ to mean not to translate; but if we don't translate it it will never match anything. */ if (translate) c = translate[c]; goto normal_char; } break; default: normal_char: if (!pending_exact || pending_exact + *pending_exact + 1 != b || *pending_exact == 0177 || *p == '*' || *p == '^' || ((obscure_syntax & RE_BK_PLUS_QM) ? *p == '\\' && (p[1] == '+' || p[1] == '?') : (*p == '+' || *p == '?'))) { laststart = b; PATPUSH (exactn); pending_exact = b; PATPUSH (0); } PATPUSH (c); (*pending_exact)++; } } if (fixup_jump) store_jump (fixup_jump, jump, b); if (stackp != stackb) goto unmatched_open; bufp->used = b - bufp->buffer; return 0; invalid_pattern: return "Invalid regular expression"; unmatched_open: return "Unmatched \\("; unmatched_close: return "Unmatched \\)"; end_of_pattern: return "Premature end of regular expression"; nesting_too_deep: return "Nesting too deep"; too_big: return "Regular expression too big"; memory_exhausted: return "Memory exhausted";}/* Store where `from' points a jump operation to jump to where `to' points. `opcode' is the opcode to store. */static intstore_jump (from, opcode, to) char *from, *to; char opcode;{ from[0] = opcode; from[1] = (to - (from + 3)) & 0377; from[2] = (to - (from + 3)) >> 8;}/* Open up space at char FROM, and insert there a jump to TO. CURRENT_END gives te end of the storage no in use, so we know how much data to copy up. OP is the opcode of the jump to insert. If you call this function, you must zero out pending_exact. */static intinsert_jump (op, from, to, current_end) char op; char *from, *to, *current_end;{ register char *pto = current_end + 3; register char *pfrom = current_end; while (pfrom != from) *--pto = *--pfrom; store_jump (from, op, to);} /* Given a pattern, compute a fastmap from it. The fastmap records which of the (1 << BYTEWIDTH) possible characters can start a string that matches the pattern. This fastmap is used by re_search to skip quickly over totally implausible text. The caller must supply the address of a (1 << BYTEWIDTH)-byte data area as bufp->fastmap. The other components of bufp describe the pattern to be used. */voidre_compile_fastmap (bufp) struct re_pattern_buffer *bufp;{ unsigned char *pattern = (unsigned char *) bufp->buffer; int size = bufp->used; register char *fastmap = bufp->fastmap; register unsigned char *p = pattern; register unsigned char *pend = pattern + size; register int j, k; unsigned char *translate = (unsigned char *) bufp->translate; unsigned char *stackb[NFAILURES]; unsigned char **stackp = stackb; bzero (fastmap, (1 << BYTEWIDTH)); bufp->fastmap_accurate = 1; bufp->can_be_null = 0; while (p) { if (p == pend) { bufp->can_be_null = 1; break; }#ifdef SWITCH_ENUM_BUG switch ((int) ((enum regexpcode) *p++))#else switch ((enum regexpcode) *p++)#endif { case exactn: if (translate) fastmap[translate[p[1]]] = 1; else fastmap[p[1]] = 1; break; case begline: case before_dot: case at_dot: case after_dot: case begbuf: case endbuf: case wordbound: case notwordbound: case wordbeg: case wordend: continue; case endline: if (translate) fastmap[translate['\n']] = 1; else fastmap['\n'] = 1; if (bufp->can_be_null != 1) bufp->can_be_null = 2; break; case finalize_jump: case maybe_finalize_jump: case jump: case dummy_failure_jump: bufp->can_be_null = 1; j = *p++ & 0377; j += SIGN_EXTEND_CHAR (*(char *)p) << 8; p += j + 1; /* The 1 compensates for missing ++ above */ if (j > 0) continue; /* Jump backward reached implies we just went through the body of a loop and matched nothing. Opcode jumped to should be an on_failure_jump. Just treat it like an ordinary jump. For a * loop, it has pushed its failure point already; if so, discard that as redundant. */ if ((enum regexpcode) *p != on_failure_jump) continue; p++; j = *p++ & 0377; j += SIGN_EXTEND_CHAR (*(char *)p) << 8; p += j + 1; /* The 1 compensates for missing ++ above */ if (stackp != stackb && *stackp == p) stackp--; continue; case on_failure_jump: j = *p++ & 0377; j += SIGN_EXTEND_CHAR (*(char *)p) << 8; p++; *++stackp = p + j; continue; case start_memory: case stop_memory: p++; continue; case duplicate: bufp->can_be_null = 1; fastmap['\n'] = 1; case anychar: for (j = 0; j < (1 << BYTEWIDTH); j++) if (j != '\n') fastmap[j] = 1; if (bufp->can_be_null) return; /* Don't return; check the alternative paths so we can set can_be_null if appropriate. */ break; case wordchar: for (j = 0; j < (1 << BYTEWIDTH); j++) if (SYNTAX (j) == Sword) fastmap[j] = 1; break; case notwordchar: for (j = 0; j < (1 << BYTEWIDTH); j++) if (SYNTAX (j) != Sword) fastmap[j] = 1; break;#ifdef emacs case syntaxspec: k = *p++; for (j = 0; j < (1 << BYTEWIDTH); j++) if (SYNTAX (j) == (enum syntaxcode) k) fastmap[j] = 1; break; case notsyntaxspec: k = *p++; for (j = 0; j < (1 << BYTEWIDTH); j++) if (SYNTAX (j) != (enum syntaxcode) k) fastmap[j] = 1; break;#endif /* emacs */ case charset: for (j = *p++ * BYTEWIDTH - 1; j >= 0; j--) if (p[j / BYTEWIDTH] & (1 << (j % BYTEWIDTH))) { if (translate) fastmap[translate[j]] = 1; else fastmap[j] = 1; } break; case charset_not: /* Chars beyond end of map must be allowed */ for (j = *p * BYTEWIDTH; j < (1 << BYTEWIDTH); j++) if (translate) fastmap[translate[j]] = 1; else fastmap[j] = 1; for (j = *p++ * BYTEWIDTH - 1; j >= 0; j--) if (!(p[j / BYTEWIDTH] & (1 << (j % BYTEWIDTH)))) { if (translate) fastmap[translate[j]] = 1; else fastmap[j] = 1; } break; } /* Get here means we have successfully found the possible starting characters of one path of the pattern. We need not follow this path any farther. Instead, look at the next alternative remembered in the stack. */ if (stackp != stackb) p = *stackp--; else break; }} /* Like re_search_2, below, but only one string is specified. */intre_search (pbufp, string, size, startpos, range, regs) struct re_pattern_buffer *pbufp; char *string; int size, startpos, range; struct re_registers *regs;{ return re_search_2 (pbufp, 0, 0, string, size, startpos, range, regs, size);}/* Like re_match_2 but tries first a match starting at index STARTPOS, then at STARTPOS + 1, and so on. RANGE is the number of places to try before giving up. If RANGE is negative, the starting positions tried are STARTPOS, STARTPOS - 1, etc. It is up to the caller to make sure that range is not so large as to take the starting position outside of the input strings.The value returned is the position at which the match was found, or -1 if no match was found, or -2 if error (such as failure stack overflow). */intre_search_2 (pbufp, string1, size1, string2, size2, startpos, range, regs, mstop) struct re_pattern_buffer *pbufp; char *string1, *string2; int size1, size2; int startpos; int range; struct re_registers *regs; int mstop;{ register char *fastmap = pbufp->fastmap; register unsigned char *translate = (unsigned char *) pbufp->translate; int total = size1 + size2; int val; /* Update the fastmap now if not correct already */ if (fastmap && !pbufp->fastmap_accurate) re_compile_fastmap (pbufp); /* Don't waste time in a long search for a pattern that says it is anchored. */ if (pbufp->used > 0 && (enum regexpcode) pbufp->buffer[0] == begbuf && range > 0) { if (startpos > 0) return -1; else range = 1; } while (1) { /* If a fastmap is supplied, skip quickly over characters that cannot possibly be the start of a match. Note, however, that if the pattern can possibly match the null string, we must test it at each starting point so that we take the first null string we get. */ if (fastmap && startpos < total && pbufp->can_be_null != 1) { if (range > 0) { register int lim = 0; register unsigned char *p; int irange = range; if (startpos < size1 && startpos + range >= size1) lim = range - (size1 - startpos); p = ((unsigned char *) &(startpos >= size1 ? string2 - size1 : string1)[startpos]); if (translate) { while (range > lim && !fastmap[translate[*p++]]) range--; } else { while (range > lim && !fastmap[*p++]) range--; } startpos += irange - range; } else { register unsigned char c; if (startpos >= size1) c = string2[startpos - size1]; else c = string1[startpos]; c &= 0xff; if (translate ? !fastmap[translate[c]] : !fastmap[c]) goto advance; } } if (range >= 0 && startpos == total && fastmap && pbufp->can_be_null == 0) return -1; val = re_match_2 (pbufp, (unsigned char *)string1, size1, (unsigned char *)string2, size2, startpos, regs, mstop); if (0 <= val) { == -2) return -2; return startpos; }#ifdef C_ALLOCA alloca (0);#endif /* C_ALLOCA */ advance: if (!range) break; if (range > 0) range--, startpos++; else range++, startpos--; } return -1;} #ifndef emacs /* emacs never uses this */intre_match (pbufp, string, size, pos, regs) struct re_pattern_buffer *pbuf
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:gawk:gawk-2.11:regex.c
+++++ Continued from previous card +++++
p; char *string; int size, pos; struct re_registers *regs;{ return re_match_2 (pbufp, (unsigned char *)0, 0, (unsigned char *)string, size, pos, regs, size);}#endif /* emacs *//* Maximum size of failure stack. Beyond this, overflow is an error. */int re_max_failures = 2000;static int bcmp_translate();/* Match the pattern described by PBUFP against data which is the virtual concatenation of STRING1 and STRING2. SIZE1 and SIZE2 are the sizes of the two data strings. Start the match at position POS. Do not consider matching past the position MSTOP. If pbufp->fastmap is nonzero, then it had better be up to date. The reason that the data to match are specified as two components which are to be regarded as concatenated is so this function can be used directly on the contents of an Emacs buffer. -1 is returned if there is no match. -2 is returned if there is an error (such as match stack overflow). Otherwise the value is the length of the substring which was matched. */intre_match_2 (pbufp, string1, size1, string2, size2, pos, regs, mstop) struct re_pattern_buffer *pbufp; unsigned char *string1, *string2; int size1, size2; int pos; struct re_registers *regs; int mstop;{ register unsigned char *p = (unsigned char *) pbufp->buffer; register unsigned char *pend = p + pbufp->used; /* End of first string */ unsigned char *end1; /* End of second string */ unsigned char *end2; /* Pointer just past last char to consider matching */ unsigned char *end_match_1, *end_match_2; register unsigned char *d, *dend; register int mcnt; unsigned char *translate = (unsigned char *) pbufp->translate; /* Failure point stack. Each place that can handle a failure further down the line pushes a failure point on this stack. It consists of two char *'s. The first one pushed is where to resume scanning the pattern; the second pushed is where to resume scanning the strings. If the latter is zero, the failure point is a "dummy". If a failure happens and the innermost failure point is dormant, it discards that failure point and tries the next one. */ unsigned char *initial_stack[2 * NFAILURES]; unsigned char **stackb = initial_stack; unsigned char **stackp = stackb, **stacke = &stackb[2 * NFAILURES]; /* Information on the "contents" of registers. These are pointers into the input strings; they record just what was matched (on this attempt) by some part of the pattern. The start_memory command stores the start of a register's contents and the stop_memory command stores the end. At that point, regstart[regnum] points to the first character in the register, regend[regnum] points to the first character beyond the end of the register, regstart_seg1[regnum] is true iff regstart[regnum] points into string1, and regend_seg1[regnum] is true iff regend[regnum] points into string1. */ unsigned char *regstart[RE_NREGS]; unsigned char *regend[RE_NREGS]; unsigned char regstart_seg1[RE_NREGS], regend_seg1[RE_NREGS]; /* Set up pointers to ends of strings. Don't allow the second string to be empty unless both are empty. */ if (!size2) { string2 = string1; size2 = size1; string1 = 0; size1 = 0; } end1 = string1 + size1; end2 = string2 + size2; /* Compute where to stop matching, within the two strings */ if (mstop <= size1) { end_match_1 = string1 + mstop; end_match_2 = string2; } else { end_match_1 = end1; end_match_2 = string2 + mstop - size1; } /* Initialize \) text positions to -1 to mark ones that no \( or \) has been seen for. */ for (mcnt = 0; mcnt < sizeof (regend) / sizeof (*regend); mcnt++) regend[mcnt] = (unsigned char *) -1; /* `p' scans through the pattern as `d' scans through the data. `dend' is the end of the input string that `d' points within. `d' is advanced into the following input string whenever necessary, but this happens before fetching; therefore, at the beginning of the loop, `d' can be pointing at the end of a string, but it cannot equal string2. */ if (pos <= size1) d = string1 + pos, dend = end_match_1; else d = string2 + pos - size1, dend = end_match_2;/* Write PREFETCH; just before fetching a character with *d. */#define PREFETCH \ while (d == dend) \ { if (dend == end_match_2) goto fail; /* end of string2 => failure */ \ d = string2; /* end of string1 => advance to string2. */ \ dend = end_match_2; } /* This loop loops over pattern commands. It exits by returning from the function if match is complete, or it drops through if match fails at this starting point in the input data. */ while (1) { if (p == pend) /* End of pattern means we have succeeded! */ { /* If caller wants register contents data back, convert it to indices */ if (regs) { regs->start[0] = pos; if (dend == end_match_1) regs->end[0] = d - string1; else regs->end[0] = d - string2 + size1; for (mcnt = 1; mcnt < RE_NREGS; mcnt++) { if (regend[mcnt] == (unsigned char *) -1) { regs->start[mcnt] = -1; regs->end[mcnt] = -1; continue; } if (regstart_seg1[mcnt]) regs->start[mcnt] = regstart[mcnt] - string1; else regs->start[mcnt] = regstart[mcnt] - string2 + size1; if (regend_seg1[mcnt]) regs->end[mcnt] = regend[mcnt] - string1; else regs->end[mcnt] = regend[mcnt] - string2 + size1; } } if (dend == end_match_1) return (d - string1 - pos); else return d - string2 + size1 - pos; } /* Otherwise match next pattern command */#ifdef SWITCH_ENUM_BUG switch ((int) ((enum regexpcode) *p++))#else switch ((enum regexpcode) *p++)#endif { /* \( is represented by a start_memory, \) by a stop_memory. Both of those commands contain a "register number" argument. The text matched within the \( and \) is recorded under that number. Then, \<digit> turns into a `duplicate' command which is followed by the numeric value of <digit> as the register number. */ case start_memory: regstart[*p] = d; regstart_seg1[*p++] = (dend == end_match_1); break; case stop_memory: regend[*p] = d; regend_seg1[*p++] = (dend == end_match_1); break; case duplicate: { int regno = *p++; /* Get which register to match against */ register unsigned char *d2, *dend2; d2 = regstart[regno]; dend2 = ((regstart_seg1[regno] == regend_seg1[regno]) ? regend[regno] : end_match_1); while (1) { /* Advance to next segment in register contents, if necessary */ while (d2 == dend2) { if (dend2 == end_match_2) break; if (dend2 == regend[regno]) break; d2 = string2, dend2 = regend[regno]; /* end of string1 => advance to string2. */ } /* At end of register contents => success */ if (d2 == dend2) break; /* Advance to next segment in data being matched, if necessary */ PREFETCH; /* mcnt gets # consecutive chars to compare */ mcnt = dend - d; if (mcnt > dend2 - d2) mcnt = dend2 - d2; /* Compare that many; failure if mismatch, else skip them. */ if (translate ? bcmp_translate (d, d2, mcnt, translate) : bcmp (d, d2, mcnt)) goto fail; d += mcnt, d2 += mcnt; } } break; case anychar: /* fetch a data character */ PREFETCH; /* Match anything but a newline. */ if ((translate ? translate[*d++] : *d++) == '\n') goto fail; break; case charset: case charset_not: { /* Nonzero for charset_not */ int not = 0; register int c; if (*(p - 1) == (unsigned char) charset_not) not = 1; /* fetch a data character */ PREFETCH; if (translate) c = translate [*d]; else c = *d; if (c < *p * BYTEWIDTH && p[1 + c / BYTEWIDTH] & (1 << (c % BYTEWIDTH))) not = !not; p += 1 + *p; if (!not) goto fail; d++; break; } case begline: if (d == string1 || d[-1] == '\n') break; goto fail; case endline: if (d == end2 || (d == end1 ? (size2 == 0 || *string2 == '\n') : *d == '\n')) break; goto fail; /* "or" constructs ("|") are handled by starting each alternative with an on_failure_jump that points to the start of the next alternative. Each alternative except the last ends with a jump to the joining point. (Actually, each jump except for the last one really jumps to the following jump, because tensioning the jumps is a hassle.) */ /* The start of a stupid repeat has an on_failure_jump that points past the end of the repeat text. This makes a failure point so that, on failure to match a repetition, matching restarts past as many repetitions have been found with no way to fail and look for another one. */ /* A smart repeat is similar but loops back to the on_failure_jump so that each repetition makes another failure point. */ case on_failure_jump: if (stackp == stacke) { unsigned char **stackx; if (stacke - stackb > re_max_failures * 2) return -2; stackx = (unsigned char **) alloca (2 * (stacke - stackb) * sizeof (char *)); bcopy (stackb, stackx, (stacke - stackb) * sizeof (char *)); stackp = stackx + (stackp - stackb); stacke = stackx + 2 * (stacke - stackb); stackb = stackx; } mcnt = *p++ & 0377; mcnt += SIGN_EXTEND_CHAR (*(char *)p) << 8; p++; *stackp++ = mcnt + p; *stackp++ = d; break; /* The end of a smart repeat has an maybe_finalize_jump back. Change it either to a finalize_jump or an ordinary jump. */ case maybe_finalize_jump: mcnt = *p++ & 0377; mcnt += SIGN_EXTEND_CHAR (*(char *)p) << 8; p++; { register unsigned char *p2 = p; /* Compare what follows with the begining of the repeat. If we can establish that there is nothing that they would both match, we can change to finalize_jump */ while (p2 != pend && (*p2 == (unsigned char) stop_memory || *p2 == (unsigned char) start_memory)) p2++; if (p2 == pend) p[-3] = (unsigned char) finalize_jump; else if (*p2 == (unsigned char) exactn || *p2 == (unsigned char) endline) { register int c = *p2 == (unsigned char) endline ? '\n' : p2[2]; register unsigned char *p1 = p + mcnt; /* p1[0] ... p1[2] are an on_failure_jump. Examine what follows that */ if (p1[3] == (unsigned char) exactn && p1[5] != c) p[-3] = (unsigned char) finalize_jump; else if (p1[3] == (unsigned char) charset || p1[3] == (unsigned char) charset_not) { int not = p1[3] == (unsigned char) charset_not; if (c < p1[4] * BYTEWIDTH && p1[5 + c / BYTEWIDTH] & (1 << (c % BYTEWIDTH))) not = !not; /* not is 1 if c would match */ /* That means it is not safe to finalize */ if (!not) p[-3] = (unsigned char) finalize_jump; } } } p -= 2; if (p[-1] != (unsigned char) finalize_jump) { p[-1] = (unsigned char) jump; goto nofinalize; } /* The end of a stupid repeat has a finalize-jump back to the start, where another failure point will be made which will point after all the repetitions found so far. */ case finalize_jump: stackp -= 2; case jump: nofinalize: mcnt = *p++ & 0377; mcnt += SIGN_EXTEND_CHAR (*(char *)p) << 8; p += mcnt + 1; /* The 1 compensates for missing ++ above */ break; case dummy_failure_jump: if (stackp == stacke) { unsigned char **stackx = (unsigned char **) alloca (2 * (stacke - stackb) * sizeof (char *)); bcopy (stackb, stackx, (stacke - stackb) * sizeof (char *)); stackp = stackx + (stackp - stackb); stacke = stackx + 2 * (stacke - stackb); stackb = stackx; } *stackp++ = 0; *stackp++ = 0; goto nofinalize; case wordbound: if (d == string1 /* Points to first char */ || d == end2 /* Points to end */ || (d == end1 && size2 == 0)) /* Points to end */ break; if ((SYNTAX (d[-1]) == Sword) != (SYNTAX (d == end1 ? *string2 : *d) == Sword)) break; goto fail; case notwordbound: if (d == string1 /* Points to first char */ || d == end2 /* Points to end */ || (d == end1 && size2 == 0)) /* Points to end */ goto fail; if ((SYNTAX (d[-1]) == Sword) != (SYNTAX (d == end1 ? *string2 : *d) == Sword)) goto fail; break; case wordbeg: if (d == end2 /* Points to end */ || (d == end1 && size2 == 0) /* Points to end */ || SYNTAX (* (d == end1 ? string2 : d)) != Sword) /* Next char not a letter */ goto fail; if (d == string1 /* Points to first char */ || SYNTAX (d[-1]) != Sword) /* prev char not letter */ break; goto fail; case wordend: if (d == string1 /* Points to first char */ || SYNTAX (d[-1]) != Sword) /* prev char not letter */ goto fail; if (d == end2 /* Points to end */ || (d == end1 && size2 == 0) /* Points to end */ || SYNTAX (d == end1 ? *string2 : *d) != Sword) /* Next char not a letter */ break; goto fail;#ifdef emacs case before_dot: if (((d - string2 <= (unsigned) size2) ? d - bf_p2 : d - bf_p1) <= point) goto fail; break; case at_dot: if (((d - string2 <= (unsigned) size2) ? d - bf_p2 : d - bf_p1) == point) goto fail; break; case after_dot: if (((d - string2 <= (unsigned) size2) ? d - bf_p2 : d - bf_p1) >= point) goto fail; break; case wordchar: mcnt = (int) Sword; goto matchsyntax; case syntaxspec: mcnt = *p++; matchsyntax: PREFETCH; if (SYNTAX (*d++) != (enum syntaxcode) mcnt) goto fail; break; case notwordchar: mcnt = (int) Sword; goto matchnotsyntax; case notsyntaxspec: mcnt = *p++; matchnotsyntax: PREFETCH; if (SYNTAX (*d++) == (enum syntaxcode) mcnt) goto fail; break;#else case wordchar: PREFETCH; if (SYNTAX (*d++) == 0) goto fail; break; case notwordchar: PREFETCH; if (SYNTAX (*d++) != 0) goto fail; break;#endif /* not emacs */ case begbuf: if (d == string1) /* Note, d cannot equal string2 */ break; /* unless string1 == string2. */ goto fail; case endbuf: if (d == end2 || (d == end1 && size2 == 0)) break; goto fail; case exactn: /* Match the next few pattern characters exactly. mcnt is how many characters to match. */ mcnt = *p++; if (translate) { do { PREFETCH; if (translate[*d++] != *p++) goto fail; } while (--mcnt); } else { do { PREFETCH; if (*d++ != *p++) goto fail; } while (--mcnt); } break; } continue; /* Successfully matched one pattern command; keep matching */ /* Jump here if any matching operation fails. */ fail: if (stackp != stackb) /* A restart point is known. Restart there and pop it. */ { if (!stackp[-2]) { /* If innermost failure point is dormant, flush it and keep looking */ stackp -= 2; goto fail; } d = *--stackp; p = *--stackp; if (d >= string1 && d <= end1) dend = end_match_1; } else break; /* Matching at this starting point really fails! */ } return -1; /* Failure to match */}static intbcmp_translate (s1, s2, len, translate) unsigned char *s1, *s2; register int len; unsigned char *translate;{ register unsigned char *p1 = s1, *p2 = s2; while (len) { if (translate [*p1++] != translate [
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:gawk:gawk-2.11:regex.c
+++++ Continued from previous card +++++
*p2++]) return 1; len--; } return 0;} /* Entry points compatible with bsd4.2 regex library */#ifndef emacsstatic struct re_pattern_buffer re_comp_buf;char *re_comp (s) char *s;{ if (!s) { if (!re_comp_buf.buffer) return "No previous regular expression"; return 0; } if (!re_comp_buf.buffer) { if (!(re_comp_buf.buffer = (char *) malloc (200))) return "Memory exhausted"; re_comp_buf.allocated = 200; if (!(re_comp_buf.fastmap = (char *) malloc (1 << BYTEWIDTH))) return "Memory exhausted"; } return re_compile_pattern (s, strlen (s), &re_comp_buf);}intre_exec (s) char *s;{ int len = strlen (s); return 0 <= re_search (&re_comp_buf, s, len, 0, len, 0);}#endif /* emacs */ #ifdef test#include <stdio.h>/* Indexed by a character, gives the upper case equivalent of the character */static char upcase[0400] = { 000, 001, 002, 003, 004, 005, 006, 007, 010, 011, 012, 013, 014, 015, 016, 017, 020, 021, 022, 023, 024, 025, 026, 027, 030, 031, 032, 033, 034, 035, 036, 037, 040, 041, 042, 043, 044, 045, 046, 047, 050, 051, 052, 053, 054, 055, 056, 057, 060, 061, 062, 063, 064, 065, 066, 067, 070, 071, 072, 073, 074, 075, 076, 077, 0100, 0101, 0102, 0103, 0104, 0105, 0106, 0107, 0110, 0111, 0112, 0113, 0114, 0115, 0116, 0117, 0120, 0121, 0122, 0123, 0124, 0125, 0126, 0127, 0130, 0131, 0132, 0133, 0134, 0135, 0136, 0137, 0140, 0101, 0102, 0103, 0104, 0105, 0106, 0107, 0110, 0111, 0112, 0113, 0114, 0115, 0116, 0117, 0120, 0121, 0122, 0123, 0124, 0125, 0126, 0127, 0130, 0131, 0132, 0173, 0174, 0175, 0176, 0177, 0200, 0201, 0202, 0203, 0204, 0205, 0206, 0207, 0210, 0211, 0212, 0213, 0214, 0215, 0216, 0217, 0220, 0221, 0222, 0223, 0224, 0225, 0226, 0227, 0230, 0231, 0232, 0233, 0234, 0235, 0236, 0237, 0240, 0241, 0242, 0243, 0244, 0245, 0246, 0247, 0250, 0251, 0252, 0253, 0254, 0255, 0256, 0257, 0260, 0261, 0262, 0263, 0264, 0265, 0266, 0267, 0270, 0271, 0272, 0273, 0274, 0275, 0276, 0277, 0300, 0301, 0302, 0303, 0304, 0305, 0306, 0307, 0310, 0311, 0312, 0313, 0314, 0315, 0316, 0317, 0320, 0321, 0322, 0323, 0324, 0325, 0326, 0327, 0330, 0331, 0332, 0333, 0334, 0335, 0336, 0337, 0340, 0341, 0342, 0343, 0344, 0345, 0346, 0347, 0350, 0351, 0352, 0353, 0354, 0355, 0356, 0357, 0360, 0361, 0362, 0363, 0364, 0365, 0366, 0367, 0370, 0371, 0372, 0373, 0374, 0375, 0376, 0377 };main (argc, argv) int argc; char **argv;{ char pat[80]; struct re_pattern_buffer buf; int i; char c; char fastmap[(1 << BYTEWIDTH)]; /* Allow a command argument to specify the style of syntax. */ if (argc > 1) obscure_syntax = atoi (argv[1]); buf.allocated = 40; buf.buffer = (char *) malloc (buf.allocated); buf.fastmap = fastmap; buf.translate = upcase; while (1) { gets (pat); if (*pat) { re_compile_pattern (pat, strlen(pat), &buf); for (i = 0; i < buf.used; i++) printchar (buf.buffer[i]); putchar ('\n'); printf ("%d allocated, %d used.\n", buf.allocated, buf.used); re_compile_fastmap (&buf); printf ("Allowed by fastmap: "); for (i = 0; i < (1 << BYTEWIDTH); i++) if (fastmap[i]) printchar (i); putchar ('\n'); } gets (pat); /* Now read the string to match against */ i = re_match (&buf, pat, strlen (pat), 0, 0); printf ("Match value %d.\n", i); }}#ifdef NOTDEFprint_buf (bufp) struct re_pattern_buffer *bufp;{ int i; printf ("buf is :\n----------------\n"); for (i = 0; i < bufp->used; i++) printchar (bufp->buffer[i]); printf ("\n%d allocated, %d used.\n", bufp->allocated, bufp->used); printf ("Allowed by fastmap: "); for (i = 0; i < (1 << BYTEWIDTH); i++) if (bufp->fastmap[i]) printchar (i); printf ("\nAllowed by translate: "); if (bufp->translate) for (i = 0; i < (1 << BYTEWIDTH); i++) if (bufp->translate[i]) printchar (i); printf ("\nfastmap is%s accurate\n", bufp->fastmap_accurate ? "" : "n't"); printf ("can %s be null\n----------", bufp->can_be_null ? "" : "not");}#endifprintchar (c) char c;{ if (c < 041 || c >= 0177) { putchar ('\\'); putchar (((c >> 6) & 3) + '0'); putchar (((c >> 3) & 7) + '0'); putchar ((c & 7) + '0'); } else putchar (c);}#endif /* test */ :MPW:MPW Tools:Tools with Source:gawk:gawk-2.11:regex.h
/* Definitions for data structures callers pass the regex library. Copyright (C) 1985 Free Software Foundation, Inc. NO WARRANTY BECAUSE THIS PROGRAM IS LICENSED FREE OF CHARGE, WE PROVIDE ABSOLUTELYNO WARRANTY, TO THE EXTENT PERMITTED BY APPLICABLE STATE LAW. EXCEPTWHEN OTHERWISE STATED IN WRITING, FREE SOFTWARE FOUNDATION, INC,RICHARD M. STALLMAN AND/OR OTHER PARTIES PROVIDE THIS PROGRAM "AS IS"WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING,BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY ANDFITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITYAND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVEDEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR ORCORRECTION. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW WILL RICHARD M.STALLMAN, THE FREE SOFTWARE FOUNDATION, INC., AND/OR ANY OTHER PARTYWHO MAY MODIFY AND REDISTRIBUTE THIS PROGRAM AS PERMITTED BELOW, BELIABLE TO YOU FOR DAMAGES, INCLUDING ANY LOST PROFITS, LOST MONIES, OROTHER SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THEUSE OR INABILITY TO USE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA ORDATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY THIRD PARTIES ORA FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS) THISPROGRAM, EVEN IF YOU HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCHDAMAGES, OR FOR ANY CLAIM BY ANY OTHER PARTY. GENERAL PUBLIC LICENSE TO COPY 1. You may copy and distribute verbatim copies of this source fileas you receive it, in any medium, provided that you conspicuously andappropriately publish on each copy a valid copyright notice "Copyright(C) 1985 Free Software Foundation, Inc."; and include following thecopyright notice a verbatim copy of the above disclaimer of warrantyand of this License. You may charge a distribution fee for thephysical act of transferring a copy. 2. You may modify your copy or copies of this source file orany portion of it, and copy and distribute such modifications underthe terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains or is a derivative of this program or any part thereof, to be licensed at no charge to all third parties on terms identical to those contained in this License Agreement (except that you may choose to grant more extensive warranty protection to some or all third parties, at your option). c) You may charge a distribution fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee.Mere aggregation of another unrelated program with this program (or itsderivative) on a volume of a storage or distribution medium does not bringthe other program under the scope of these terms. 3. You may copy and distribute this program (or a portion or derivativeof it, under Paragraph 2) in object code or executable form under the termsof Paragraphs 1 and 2 above provided that you also do one of the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal shipping charge) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.)For an executable file, complete source code means all the source code forall modules it contains; but, as a special exception, it need not includesource code for modules which are standard libraries that accompany theoperating system on which the executable file runs. 4. You may not copy, sublicense, distribute or transfer this programexcept as expressly provided under this License Agreement. Any attemptotherwise to copy, sublicense, distribute or transfer this program is void andyour rights to use the program under this License agreement shall beautomatically terminated. However, parties who have received computersoftware programs from you with this License Agreement will not havetheir licenses terminated so long as such parties remain in full compliance. 5. If you wish to incorporate parts of this program into other freeprograms whose distribution conditions are different, write to the FreeSoftware Foundation at 675 Mass Ave, Cambridge, MA 02139. We have not yetworked out a simple rule that can be stated here, but we will often permitthis. We will be guided by the two goals of preserving the free status ofall derivatives of our free software and of promoting the sharing and reuse ofsoftware.In other words, you are welcome to use, share and improve this program.You are forbidden to forbid anyone else to use, share and improvewhat you give them. Help stamp out software-hoarding! *//* Define number of parens for which we record the beginnings and ends. This affects how much space the `struct re_registers' type takes up. */#ifndef RE_NREGS#define RE_NREGS 10#endif/* These bits are used in the obscure_syntax variable to choose among alternative regexp syntaxes. *//* 1 means plain parentheses serve as grouping, and backslash parentheses are needed for literal searching. 0 means backslash-parentheses are grouping, and plain parentheses are for literal searching. */#define RE_NO_BK_PARENS 1/* 1 means plain | serves as the "or"-operator, and \| is a literal. 0 means \| serves as the "or"-operator, and | is a literal. */#define RE_NO_BK_VBAR 2/* 0 means plain + or ? serves as an operator, and \+, \? are literals. 1 means \+, \? are operators and plain +, ? are literals. */#define RE_BK_PLUS_QM 4/* 1 means | binds tighter than ^ or $. 0 means the contrary. */#define RE_TIGHT_VBAR 8/* 1 means treat \n as an _OR operator 0 means treat it as a normal character */#define RE_NEWLINE_OR 16/* 0 means that a special characters (such as *, ^, and $) always have their special meaning regardless of the surrounding context. 1 means that special characters may act as normal characters in some contexts. Specifically, this applies to: ^ - only special at the beginning, or after ( or | $ - only special at the end, or before ) or | *, +, ? - only special when not after the beginning, (, or | */#define RE_CONTEXT_INDEP_OPS 32/* 0 means that \ before anything inside [ and ] is taken as a real \. 1 means that such a \ escapes the following character This is a special case for AWK. */#define RE_AWK_CLASS_HACK 64/* Now define combinations of bits for the standard possibilities. */#define RE_SYNTAX_POSIX_EGREP (RE_NO_BK_PARENS | RE_NO_BK_VBAR \ | RE_CONTEXT_INDEP_OPS)#define RE_SYNTAX_AWK (RE_SYNTAX_POSIX_EGREP | RE_AWK_CLASS_HACK)#define RE_SYNTAX_EGREP (RE_SYNTAX_POSIX_EGREP | RE_NEWLINE_OR)#define RE_SYNTAX_GREP (RE_BK_PLUS_QM | RE_NEWLINE_OR)#define RE_SYNTAX_EMACS 0/* This data structure is used to represent a compiled pattern. */struct re_pattern_buffer { char *buffer; /* Space holding the compiled pattern commands. */ int allocated; /* Size of space that buffer points to */ int used; /* Length of portion of buffer actually occupied */ char *fastmap; /* Pointer to fastmap, if any, or zero if none. */ /* re_search uses the fastmap, if there is one, to skip quickly over totally implausible characters */ char *translate; /* Translate table to apply to all characters before comparing. Or zero for no translation. The translation is applied to a pattern when it is compiled and to data when it is matched. */ char fastmap_accurate; /* Set to zero when a new pattern is stored, set to one when the fastmap is updated from it. */ char can_be_null; /* Set to one by compiling fastmap if this pattern might match the null string. It does not necessarily match the null string in that case, but if this is zero, it cannot. 2 as value means can match null string but at end of range or before a character listed in the fastmap. */ };/* Structure to store "register" contents data in. Pass the address of such a structure as an argument to re_match, etc., if you want this information back. start[i] and end[i] record the string matched by \( ... \) grouping i, for i from 1 to RE_NREGS - 1. start[0] and end[0] record the entire string matched. */struct re_registers { int start[RE_NREGS]; int end[RE_NREGS]; };/* These are the command codes that appear in compiled regular expr one per byte. Some command codes are followed by argument bytes. A command code can specify any interpretation whatever for its arguments. Zero-bytes may appear in the compiled regular expression. */enum regexpcode { unused, exactn, /* followed by one byte giving n, and then by n literal bytes */ begline, /* fails unless at beginning of line */ endline, /* fails unless at end of line */ jump, /* followed by two bytes giving relative address to jump to */ on_failure_jump, /* followed by two bytes giving relative address of place to resume at in case of failure. */ finalize_jump, /* Throw away latest failure point and then jump to address. */ maybe_finalize_jump, /* Like jump but finalize if safe to do so. This is used to jump back to the beginning of a repeat. If the command that follows this jump is clearly incompatible with the one at the beginning of the repeat, such that we can be sure that there is no use backtracking out of repetitions already completed, then we finalize. */ dummy_failure_jump, /* jump, and push a dummy failure point. This failure point will be thrown away if an attempt is made to use it for a failure. A + construct makes this before the first repeat. */ anychar, /* matches any one character */ charset, /* matches any one char belonging to specified set. First following byte is # bitmap bytes. Then come bytes for a bit-map saying which chars are in. Bits in each byte are ordered low-bit-first. A character is in the set if its bit is 1. A character too large to have a bit in the map is automatically not in the set */ charset_not, /* similar but match any character that is NOT one of those specified */ start_memory, /* starts remembering the text that is matched and stores it in a memory register. followed by one byte containing the register number. Register numbers must be in the range 0 through NREGS. */ stop_memory, /* stops remembering the text that is matched and stores it in a memory register. followed by one byte containing the register number. Register numbers must be in the range 0 through NREGS. */ duplicate, /* match a duplicate of something remembered. Followed by one byte containing the index of the memory register. */ before_dot, /* Succeeds if before dot */ at_dot, /* Succeeds if at dot */ after_dot, /* Succeeds if after dot */ begbuf, /* Succeeds if at beginning of buffer */ endbuf, /* Succeeds if at end of buffer */ wordchar, /* Matches any word-constituent character */ notwordchar, /* Matches any char that is not a word-constituent */ wordbeg, /* Succeeds if at word beginning */ wordend, /* Succeeds if at word end */ wordbound, /* Succeeds if at a word boundary */ notwordbound, /* Succeeds if not at a word boundary */ syntaxspec, /* Matches any character whose syntax is specified. followed by a byte which contains a syntax code, Sword or such like */ notsyntaxspec /* Matches any character whose syntax differs from the specified. */ }; extern char *re_compile_pattern ();/* Is this really advertised? */extern void re_compile_fastmap ();extern int re_search (), re_search_2 ();extern int re_match (), re_match_2 ();/* 4.2 bsd compatibility (yuck) */extern char *re_comp ();extern int re_exec ();#ifdef SYNTAX_TABLEextern char *re_syntax_table;#endif :MPW:MPW Tools:Tools with Source:gawk:gawk-2.11:version.c
char *version_string = "@(#)Gnu Awk (gawk) 2.11, Mac version by Tom Maszerowski";/* 1.02 fixed /= += *= etc to return the new Left Hand Side instead of the Right Hand Side *//* 1.03 Fixed split() to treat strings of space and tab as FS if the split char is ' '. Added -v option to print version number Fixed bug that caused rounding when printing large numbers *//* 2.00beta Incorporated the functionality of the "new" awk as described the book (reference not handy). Extensively tested, but no doubt still buggy. Badly needs tuning and cleanup, in particular in memory management which is currently almost non-existent. *//* 2.01 JF: Modified to compile under GCC, and fixed a few bugs while I was at it. I hope I didn't add any more. I modified parse.y to reduce the number of reduce/reduce conflicts. There are still a few left. *//* 2.02 Fixed JF's bugs; improved memory management, still needs lots of work. *//* 2.10 Major grammar rework and lots of bug fixes from David. Major changes for performance enhancements from David. A number of minor bug fixes and new features from Arnold. Changes for MSDOS from Conrad Kwok and Scott Garfinkle. The gawk.texinfo and info files included! *//* 2.11 Bug fix release to 2.10. Lots of changes for portability, speed, and configurability. Macintosh version for THINK C based on this release. */ :MPW:MPW Tools:Tools with Source:gawk:MACINTOSH.README
About GNU awk for the Macintosh...This is GNU awk, gawk, for the Macintosh. For those who don’t know, GNU standsfor GNU’s Not UNIX, an as-yet unfinished operating system,and is the primarygoal of the Free Software Foundation. The FSF has publically condemned AppleComputer for it’s litigation in defense of perceived copyrights. The FSF,therefore, has no knowledge of the existence of this gawk version, and wouldnot support it if it did. Do not report bugs or make any other contact with FSFconcerning Macintosh gawk. Why Macintosh gawk existsgawk for the Macintosh exists for a number of reasons. First, I use gawkextensively as part of my day to day work activities and wanted to have it athome. Second, I was looking for a project in C to work on at home to learn Macprogramming. And third, it was a challenge. I have every intention of followingthe GNU copyleft, meaning that I can not sell gawk for profit and must alsomake full source available. Macintosh gawk is Free Software Macgawk is distributed totally free of charge. It is not shareware or publicdomain. I encourage you to read the documents that describe the GNU PublicLicense, or GPL so that you understand what this means. Differences from UNIX gawkMacinstosh gawk lacks some features that UNIX-like systems provide. Thesefeatures include pipes and multiple processes. Mac gawk will quit when sourceprograms invoke these functions. I caution against redirecting input and outputin getline and print/printf calls. All other features should work the same. Macintosh caveats Multifinder Mac gawk will run under Multifinder, but is not particularly MF adapted. It isset to use a partition size of 768K but large input files may require more,much more. Operation under Finder should be fine. Command LineMacintosh gawk uses the THINK C ccommand interface. This provides a dialog boxthat allows the user to enter UNIX shell-like command lines. Redirection ofinput and output is done with radio buttons. TEXT Files Mac gawk reads and writes standard Macintosh TEXTfiles. To use word processor files, it will be necessary to save them as TEXTfirst. Behind the scenesCompilation Mac gawk was compiled using THINK C 4.0.2 on a 4M Mac+ runningSystem 6.0.2. gawk requires bison to generate the awk.tab.c file. This isgenerally only required when making changes in the actual awk language. Thesource files were converted to comply with the ANSI standard ( as THINK definesit ) and makes full use of function prototypes. The authorI’m not really the author, I just did the porting. My name is Tom Maszerowski,I work for CPU Inc. as a consulting software engineer at Moscom, Inc. in EastRochester, NY. I mention this in expectation that I may not always be availableat the addresses listed below. Moscom is nice enough to allow me email and UUCPacccess and I thank them, but there are no guarantees. Thanks to my wife aswell, for allowing me the time at home to do this. Bugs and updatesPlease do not contact the FSF concerning this version of gawk. I expect to bethe sole point of contact for bugs and source code updates. I monitor the GNUgroups on NETNEWS and will try to incorporate them as needed. If you makechanges to the gawk source you feel will benefit others send them to me. AddressesI can be reached at the following email addresses: tcm@moscom.com {rit,tropix,ur-valhalla}!moscom!tcmMail delivery is usually quite good and I try to respond in a timely fashion (although timely is a subjective term ).ManualI am currently converting the GNU awk manual from texinfo format toMacWrite5.0. This willl be made available as soon as possible. I expect thismeans before the end of October '90. :MPW:MPW Tools:Tools with Source:gawk ƒ:awk.h
/* * awk.h -- Definitions for gawk. * * Copyright (C) 1986 Free Software Foundation * Written by Paul Rubin, August 1986 * *//*GAWK is distributed in the hope that it will be useful, but WITHOUT ANYWARRANTY. No author or distributor accepts responsibility to anyonefor the consequences of using it or for whether it serves anyparticular purpose or works at all, unless he says so in writing.Refer to the GAWK General Public License for full details.Everyone is granted permission to copy, modify and redistribute GAWK,but only under the conditions described in the GAWK General PublicLicense. A copy of this license is supposed to have been given to youalong with GAWK so you can know your rights and responsibilities. Itshould be in a file named COPYING. Among other things, the copyrightnotice and this notice must be preserved on all copies.In other words, go ahead and share GAWK, but don't try to stopanyone else from sharing it farther. Help stamp out software hoarding!*/#define AWKNUM float#include <ctype.h>#define is_identchar(c) (isalnum(c) || (c) == '_')#define obstack_chunk_alloc lmalloc#define obstack_chunk_free free#include "obstack.h"char *lmalloc(),*realloc(),*malloc();void free();typedef enum { /* illegal entry == 0 */ Node_illegal, /* 0 */ /* binary operators lnode and rnode are the expressions to work on */ Node_times, /* 1 */ Node_quotient, /* 2 */ Node_mod, /* 3 */ Node_plus, /* 4 */ Node_minus, /* 5 */ Node_cond_pair, /* 6: conditional pair (see Node_line_range) jfw */ Node_subscript, /* 7 */ Node_concat, /* 8 */ /* unary operators subnode is the expression to work on */ Node_preincrement, /* 9 */ Node_predecrement, /* 10 */ Node_postincrement, /* 11 */ Node_postdecrement, /* 12 */ Node_unary_minus, /* 13 */ Node_field_spec, /* 14 */ /* assignments lnode is the var to assign to, rnode is the exp */ Node_assign, /* 15 */ Node_assign_times, /* 16 */ Node_assign_quotient, /* 17 */ Node_assign_mod, /* 18 */ Node_assign_plus, /* 19 */ Node_assign_minus, /* 20 */ /* boolean binaries lnode and rnode are expressions */ Node_and, /* 21 */ Node_or, /* 22 */ /* binary relationals compares lnode and rnode */ Node_equal, /* 23 */ Node_notequal, /* 24 */ Node_less, /* 25 */ Node_greater, /* 26 */ Node_leq, /* 27 */ Node_geq, /* 28 */ /* unary relationals works on subnode */ Node_not, /* 29 */ /* match ops (binary) work on lnode and rnode ??? */ Node_match, /* 30 */ Node_nomatch, /* 31 */ /* data items */ Node_string, /* 32 has stlen, stptr, and stref */ Node_temp_string, /* 33 has stlen, stptr, and stref */ Node_number, /* 34 has numbr */ /* program structures */ Node_rule_list, /* 35 lnode is a rule, rnode is rest of list */ Node_rule_node, /* 36 lnode is an conditional, rnode is statement */ Node_statement_list, /* 37 lnode is a statement, rnode is more list */ Node_if_branches, /* 38 lnode is to run on true, rnode on false */ Node_expression_list, /* 39 lnode is an exp, rnode is more list */ /* keywords */ Node_K_BEGIN, /* 40 no stuff */ Node_K_END, /* 41 ditto */ Node_K_if, /* 42 lnode is conditonal, rnode is if_branches */ Node_K_while, /* 43 lnode is condtional, rnode is stuff to run */ Node_K_for, /* 44 lnode is for_struct, rnode is stuff to run */ Node_K_arrayfor, /* 45 lnode is for_struct, rnode is stuff to run */ Node_K_break, /* 46 no subs */ Node_K_continue, /* 47 no stuff */ Node_K_print, /* 48 lnode is exp_list, rnode is redirect */ Node_K_printf, /* 49 lnode is exp_list, rnode is redirect */ Node_K_next, /* 50 no subs */ Node_K_exit, /* 51 subnode is return value, or NULL */ /* I/O redirection for print statements */ Node_redirect_output, /* 52 subnode is where to redirect */ Node_redirect_append, /* 53 subnode is where to redirect */ Node_redirect_pipe, /* 54 subnode is where to redirect */ /* Variables */ Node_var, /* 55 rnode is value, lnode is array stuff */ Node_var_array, /* 56 array is ptr to elements, asize num of eles */ /* Builtins subnode is explist to work on, proc is func to call */ Node_builtin, /* 57 */ /* pattern: conditional ',' conditional ; lnode of Node_line_range is * the two conditionals (Node_cond_pair), other word (rnode place) is * a flag indicating whether or not this range has been entered. * (jfw@eddie.mit.edu) */ Node_line_range, /* 58 */} NODETYPE;typedef struct exp_node { NODETYPE type; union { struct { struct exp_node *lptr; union { struct exp_node *rptr; struct exp_node *(* pptr)(); struct re_pattern_buffer *preg; struct for_loop_header *hd; struct ahash **av; int r_ent; /* range entered (jfw) */ } r; } nodep; struct { struct exp_node **ap; int as; } ar; struct { char *sp; short slen,sref; } str; AWKNUM fltnum; } sub;} NODE;#define lnode sub.nodep.lptr#define rnode sub.nodep.r.rptr#define subnode lnode#define proc sub.nodep.r.pptr#define reexp lnode#define rereg sub.nodep.r.preg#define forsub lnode#define forloop sub.nodep.r.hd#define array sub.ar.ap#define arrsiz sub.ar.as#define stptr sub.str.sp#define stlen sub.str.slen#define stref sub.str.sref#define numbr sub.fltnum#define var_value lnode#define var_array sub.nodep.r.av#define condpair lnode#define triggered sub.nodep.r.r_entNODE *newnode(), *dupnode();NODE *node(), *snode(), *make_number(), *make_string();NODE *mkrangenode(); /* to remove the temptation to use sub.nodep.r.rptr * as a boolean flag, or to call node() with a 0 and * hope that it will store correctly as an int. (jfw) */NODE *tmp_string(),*tmp_number();NODE *variable(), *append_right();NODE *tree_eval();struct re_pattern_buffer *make_regexp();extern NODE *Nnull_string;#ifdef FASTdouble atof();NODE *strforce();#define force_number(x) ((x)->type==Node_number ? (x)->numbr : atof((x)->stptr))#define force_string(x) ((x)->type==Node_number ? (strforce(x)) : (x))#define tmp_node(ty) (global_tmp=(NODE *)obstack_alloc(&temp_strings,sizeof(NODE)),global_tmp->type=ty)#define tmp_number(n) (tmp_node(Node_number),global_tmp->numbr=(n),global_tmp)/* #define tmp_string(s,len) (tmp_node(Node_temp_string),global_tmp->stref=1,global_tmp->stlen=len,global_tmp->stptr=(char *)obstack_alloc(&temp_strings,len+1),bcopy(s,global_tmp->stptr,len),global_tmp->stptr[len]='\0',global_tmp) */NODE *global_tmp;#elseAWKNUM force_number();NODE *force_string();#endifNODE *expression_value;#define HASHSIZE 101typedef struct hashnode HASHNODE;struct hashnode { HASHNODE *next; char *name; int length; NODE *value;} *variables[HASHSIZE];typedef struct ahash AHASH;struct ahash { AHASH *next; NODE *name, *symbol, *value;};typedef struct for_loop_header { NODE *init; NODE *cond; NODE *incr;} FOR_LOOP_HEADER;FOR_LOOP_HEADER *make_for_loop();#define ADD_ONE_REFERENCE(s) ++(s)->stref#define FREE_ONE_REFERENCE(s) {\ if(s==Nnull_string) {\ fprintf(stderr,"Free_Nnull_string %d",(s)->stref);\ }\ if (--(s)->stref == 0) {\ free((char *)((s)->stptr));\ free((char *)s);\ }\}/* #define FREE_ONE_REFERENCE(s) {if (--(s)->stref == 0) {printf("FREE %x\n",s);free((s)->stptr);free(s);}} */ :MPW:MPW Tools:Tools with Source:gawk ƒ:awk.tab.c
1, -1, 30, 31, 32, 3, 34, 5, 14, -1, 8, 28, 29, 41, 12, 43, 44, 15, 16, -1, 48, -1, 39, -1, -1, -1, -1, 33, 34, 35, 36, 37, 30, 31, 32, 3, 34, 5, 36, -1, 8, -1, 40, 41, -1, -1, -1, 15, 16, -1, 48, -1, 8, 9, -1, -1, 3, -1, 5, 15, -1, 8, 30, 31, 32, -1, 34, -1, 36, 3, -1, 5, 40, 41, 8, -1, -1, 45, 34, 35, 48, 15, 16, 30, 31, 32, -1, 34, 3, -1, 5, -1, -1, 8, 41, -1, 30, 31, 32, -1, 34, 48, 36, 3, -1, 5, 40, 41, 8, 33, 34, 35, 36, 37, 48, 30, 31, 32, -1, 34, -1, -1, -1, 14, -1, -1, 41, -1, -1, -1, 30, 31, 32, 48, 34, 14, -1, -1, -1, -1, -1, 41, 33, 34, 35, 36, 37, -1, 48, 10, 11, 42, -1, 14, 33, 34, 35, 36, 37, -1, -1, -1, -1, 42, -1, -1, -1, -1, -1, -1, -1, -1, 33, 34, 35, 36, 37};#define YYPURE 1#line 2 "bison.simple"/* Skeleton output parser for bison, copyright (C) 1984 Bob Corbett and Richard Stallman NO WARRANTY BECAUSE THIS PROGRAM IS LICENSED FREE OF CHARGE, WE PROVIDE ABSOLUTELYNO WARRANTY, TO THE EXTENT PERMITTED BY APPLICABLE STATE LAW. EXCEPTWHEN OTHERWISE STATED IN WRITING, FREE SOFTWARE FOUNDATION, INC,RICHARD M. STALLMAN AND/OR OTHER PARTIES PROVIDE THIS PROGRAM "AS IS"WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING,BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY ANDFITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITYAND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVEDEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR ORCORRECTION. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW WILL RICHARD M.STALLMAN, THE FREE SOFTWARE FOUNDATION, INC., AND/OR ANY OTHER PARTYWHO MAY MODIFY AND REDISTRIBUTE THIS PROGRAM AS PERMITTED BELOW, BELIABLE TO YOU FOR DAMAGES, INCLUDING ANY LOST PROFITS, LOST MONIES, OROTHER SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THEUSE OR INABILITY TO USE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA ORDATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY THIRD PARTIES ORA FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS) THISPROGRAM, EVEN IF YOU HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCHDAMAGES, OR FOR ANY CLAIM BY ANY OTHER PARTY. GENERAL PUBLIC LICENSE TO COPY 1. You may copy and distribute verbatim copies of this source fileas you receive it, in any medium, provided that you conspicuously andappropriately publish on each copy a valid copyright notice "Copyright(C) 1985 Free Software Foundation, Inc."; and include following thecopyright notice a verbatim copy of the above disclaimer of warrantyand of this License. You may charge a distribution fee for thephysical act of transferring a copy. 2. You may modify your copy or copies of this source file orany portion of it, and copy and distribute such modifications underthe terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains or is a derivative of this program or any part thereof, to be licensed at no charge to all third parties on terms identical to those contained in this License Agreement (except that you may choose to grant more extensive warranty protection to third parties, at your option). c) You may charge a distribution fee for the physical act of transferring a copy, and you may at your optionarranty protection in exchange for a fee. 3. You may copy and distribute this program or any portion of it incompiled, executable or object code form under the terms of Paragraphs1 and 2 above provided that you do the following: a) cause each such copy to be accompanied by the corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) cause each such copy to be accompanied by a written offer, with no time limit, to give any third party free (except for a nominal shipping charge) a machine readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) in the case of a recipient of this program in compiled, executable or object code form (without the corresponding source code) you shall cause copies you distribute to be accompanied by a copy of the written offer of source code which you received along with the copy you received. 4. You may not copy, sublicense, distribute or transfer this programexcept as expressly provided under this License Agreement. Any attemptotherwise to copy, sublicense, distribute or transfer this program is void andyour rights to use the program under this License agreement shall beautomatically terminated. However, parties who have received computersoftware programs from you with this License Agreement will not havetheir licenses terminated so long as such parties remain in full compliance. 5. If you wish to incorporate parts of this program into other freeprograms whose distribution conditions are different, write to the FreeSoftware Foundation at 675 Mass Ave, Cambridge, MA 02139. We have not yetworked out a simple rule that can be stated here, but we will often permitthis. We will be guided by the two goals of preserving the free status ofall derivatives of our free software and of promoting the sharing and reuse ofsoftware.In other words, you are welcome to use, share and improve this program.You are forbidden to forbid anyone else to use, share and improvewhat you give them. Help stamp out software-hoarding! *//* This is the parser code that is written into each bison parser when the %semantic_parser declaration is not specified in the grammar. It was written by Richard Stallman by simplifying the hairy parser used when %semantic_parser is specified. *//* Note: there must be only one dollar sign in this file. It is replaced by the list of actions, each action as one case of the switch. */#define yyerrok (yyerrstatus = 0)#define yyclearin (yychar = YYEMPTY)#define YYEMPTY -2#define YYEOF 0#define YYFAIL goto yyerrlab;#define YYTERROR 1void print_parse_tree();#ifndef YYIMPURE#define YYLEX yylex()#endif#ifndef YYPURE#define YYLEX yylex(&yylval, &yylloc)#endif/* If nonreentrant, generate the variables here */#ifndef YYIMPUREint yychar; /* the lookahead symbol */YYSTYPE yylval; /* the semantic value of the */ /* lookahead symbol */YYLTYPE yylloc; /* location data for the lookahead */ /* symbol */int yydebug = 0; /* nonzero means print parse trace */#endif /* YYIMPURE *//* YYMAXDEPTH indicates the initial size of the parser's stacks */#ifndef YYMAXDEPTH#define YYMAXDEPTH 200#endif/* YYMAXLIMIT is the maximum size the stacks can grow to (effective only if the built-in stack extension method is used). */#ifndef YYMAXLIMIT#define YYMAXLIMIT 2000 /*10000 in original*/#endif#line 87 "bison.simple"intyyparse(){ register1 int yystate; register1 int yyn; register1 short *yyssp; register1 YYSTYPE *yyvsp; YYLTYPE *yylsp; int yyerrstatus; /* number of tokens to shift before error messages enabled */ int yychar1; /* lookahead token as an internal (translated) token number */ short yyssa[YYMAXDEPTH]; /* the state stack */ YYSTYPE yyvsa[YYMAXDEPTH]; /* the semantic value stack */ YYLTYPE yylsa[YYMAXDEPTH]; /* the location stack */ short *yyss = yyssa; /* refer to the stacks thru separate pointers */ YYSTYPE *yyvs = yyvsa; /* to allow yyoverflow to reallocate them elsewhere */ YYLTYPE *yyls = yylsa; int yymaxdepth = YYMAXDEPTH;#ifndef YYPURE int yychar; YYSTYPE yylval; YYLTYPE yylloc; extern int yydebug;#endif YYSTYPE yyval; /* the variable used to return */ /* semantic values from the action */ /* routines */ int yylen; if (yydebug) fprintf(stderr, "Starting parse\n"); yystate = 0; yyerrstatus = 0; yychar = YYEMPTY; /* Cause a token to be read. */ /* Initialize stack pointers. Waste one element of value and location stack so that they stay on the same level as the state stack. */ yyssp = yyss - 1; yyvsp = yyvs; yylsp = yyls;/* Push a new state, which is found in yystate . *//* In all cases, when you get here, the value and location stacks have just been pushed. so pushing a state here evens the stacks. */yynewstate: *++yyssp = yystate; if (yyssp >= yyss + yymaxdepth - 1) { /* Give user a chance to reallocate the stack */ /* Use copies of these so that the &'s don't force the real ones into memory. */ YYSTYPE *yyvs1 = yyvs; YYLTYPE *yyls1 = yyls; short *yyss1 = yyss; /* Get the current used size of the three stacks, in elements. */ int size = yyssp - yyss + 1;#ifdef yyoverflow /* Each stack pointer address is followed by the size of the data in use in that stack, in bytes. */ yyoverflow("parser stack overflow", &yyss1, size * sizeof (*yyssp), &yyvs1, size * sizeof (*yyvsp), &yyls1, size * sizeof (*yylsp), &yymaxdepth); yyss = yyss1; yyvs = yyvs1; yyls = yyls1;#else /* no yyoverflow */ /* Extend the stack our own way. */ if (yymaxdepth >= YYMAXLIMIT) yyerror("parser stack overflow"); yymaxdepth *= 2; if (yymaxdepth > YYMAXLIMIT) yymaxdepth = YYMAXLIMIT; yyss = (short *) alloca ((long) yymaxdepth * sizeof (*yyssp)); bcopy ((char *)yyss1, (char *)yyss, size * sizeof (*yyssp)); yyls = (YYLTYPE *) alloca ((long) yymaxdepth * sizeof (*yylsp)); bcopy ((char *)yyls1, (char *)yyls, size * sizeof (*yylsp)); yyvs = (YYSTYPE *) alloca ((long) yymaxdepth * sizeof (*yyvsp)); bcopy ((char *)yyvs1, (char *)yyvs, size * sizeof (*yyvsp));#endif /* no yyoverflow */ yyssp = yyss + size - 1; yylsp = yyls + size - 1; yyvsp = yyvs + size - 1; if (yydebug) fprintf(stderr, "Stack size increased to %d\n", yymaxdepth); if (yyssp >= yyss + yymaxdepth - 1) YYERROR; } if (yydebug) fprintf(stderr, "Entering state %d\n", yystate);/* Do appropriate processing given the current state. *//* Read a lookahead token if we need one and don't already have one. */yyresume: /* First try to decide what to do without reference to lookahead token. */ yyn = yypact[yystate]; if (yyn == YYFLAG) goto yydefault; /* Not known => get a lookahead token if don't already have one. */ /* yychar is either YYEMPTY or YYEOF or a valid token in external form. */ if (yychar == YYEMPTY) { yychar = YYLEX; } /* Convert token to internal form (in yychar1) for indexing tables with */ if (yychar <= 0) /* This means end of input. */ { yychar1 = 0; yychar = YYEOF; /* Don't call YYLEX any more */ if (yydebug) fprintf(stderr, "Now at end of input.\n"); } else { yychar1 = YYTRANSLATE(yychar); if (yydebug) fprintf(stderr, "Parsing next token; it is %d (%s)\n", yychar, yytname[yychar1]); } yyn += yychar1; if (yyn < 0 || yyn > YYLAST || yycheck[yyn] != yychar1) goto yydefault; yyn = yytable[yyn]; /* yyn is what to do for this token type in this state. Negative => reduce, -yyn is rule number. Positive => shift, yyn is new state. New state is final state => don't bother to shift, just return success. 0, or most negative number => error. */ if (yyn < 0) { if (yyn == YYFLAG) goto yyerrlab; yyn = -yyn; goto yyreduce; } else if (yyn == 0) goto yyerrlab; if (yyn == YYFINAL) YYACCEPT; /* Shift the lookahead token. */ if (yydebug) fprintf(stderr, "Shifting token %d (%s), ", yychar, yytname[yychar1]); /* Discard the token being shifted unless it is eof. */ if (yychar != YYEOF) yychar = YYEMPTY; *++yyvsp = yylval; *++yylsp = yylloc; /* count tokens shifted since error; after three, turn off error status. */ if (yyerrstatus) yyerrstatus--; yystate = yyn; goto yynewstate;/* Do the default action for the current state. */yydefault: yyn = yydefact[yystate]; if (yyn == 0) goto yyerrlab;/* Do a reduction. yyn is the number of a rule to reduce with. */yyreduce: yylen = yyr2[yyn]; yyval = yyvsp[1-yylen]; /* implement default value of the action */ if (yydebug) { if (yylen == 1) fprintf (stderr, "Reducing 1 value via line %d, ", yyrline[yyn]); else fprintf (stderr, "Reducing %d values via line %d, ", yylen, yyrline[yyn]); } switch (yyn) {case 1:#line 106 "awk.y"{ expression_value = yyvsp[0].nodeval; ; break;}case 2:#line 111 "awk.y"{ yyval.nodeval = node (yyvsp[0].nodeval, Node_rule_list,(NODE *) NULL); ; break;}case 3:#line 114 "awk.y"{ yyval.nodeval = append_right (yyvsp[-1].nodeval, node(yyvsp[0].nodeval, Node_rule_list,(NODE *) NULL)); ; break;}case 4:#line 118 "awk.y"{ yyval.nodeval = node (yyvsp[-3].nodeval, Node_rule_node, yyvsp[-2].nodeval); ; break;}case 5:#line 123 "awk.y"{ yyval.nodeval = NULL; ; break;}case 6:#line 125 "awk.y"{ yyval.nodeval = yyvsp[0].nodeval; ; break;}case 7:#line 127 "awk.y"{ yyval.nodeval = mkrangenode ( node(yyvsp[-2].nodeval, Node_cond_pair, yyvsp[0].nodeval) ); ; break;}case 8:#line 133 "awk.y"{ yyval.nodeval = node ((NODE *)NULL, Node_K_BEGIN,(NODE *) NULL); ; break;}case 9:#line 135 "awk.y"{ yyval.nodeval = node ((NODE *)NULL, Node_K_END,(NODE *) NULL); ; break;}case 10:#line 137 "awk.y"{ yyval.nodeval = node (yyvsp[0].nodeval, Node_not,(NODE *) NULL); ; break;}case 11:#line 139 "awk.y"{ yyval.nodeval = node (yyvsp[-2].nodeval, Node_and, yyvsp[0].nodeval); ; break;}case 12:#line 141 "awk.y"{ yyval.nodeval = node (yyvsp[-2].nodeval, Node_or, yyvsp[0].nodeval); ; break;}case 13:#line 143 "awk.y"{ yyval.nodeval = yyvsp[-1].nodeval; want_concat_token = 0; ; break;}case 14:#line 152 "awk.y"{ ++want_regexp; ; break;}case 15:#line 154 "awk.y"{ want_regexp = 0; yyval.nodeval = node (node (make_number ((AWKNUM)0), Node_field_spec, (NODE *)NULL), Node_match, (NODE *)make_regexp (yyvsp[-1].sval)); ; break;}case 16:#line 159 "awk.y"{ ++want_regexp; ; break;}case 17:#line 161 "awk.y"{ want_regexp = 0; yyval.nodeval = node (yyvsp[-5].nodeval, yyvsp[-4].nodetypeval, (NODE *)make_regexp(yyvsp[-1].sval)); ; break;}case 18:#line 165 "awk.y"{ yyval.nodeval = node (yyvsp[-2].nodeval, yyvsp[-1].nodetypeval, yyvsp[0].nodeval); ; break;}case 19:#line 167 "awk.y"{ yyval.nodeval = yyvsp[0].nodeval; ; break;}case 20:#line 172 "awk.y"{ yyval.nodeval = NULL; ; break;}case 21:#line 174 "awk.y"{ yyval.nodeval = yyvsp[-1].nodeval; ; break;}case 22:#line 179 "awk.y"{ yyval.nodeval = NULL; ; break;}case 23:#line 181 "awk.y"{ yyval.nodeval = node (yyvsp[0].nodeval, Node_statement_list, (NODE *)NULL); ; break;}case 24:#line 183 "awk.y"{ yyval.nodeval = append_right(yyvsp[-1].nodeval, node( yyvsp[0].nodeval, Node_statement_list, (NODE *)NULL)); ; break;}case 25:#line 188 "aw
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:gawk ƒ:awk.tab.c
+++++ Continued from previous card +++++
k.y"{ yyval.nodetypeval = Node_illegal; ; break;}case 26:#line 190 "awk.y"{ yyval.nodetypeval = Node_illegal; ; break;}case 27:#line 195 "awk.y"{ yyval.nodetypeval = Node_illegal; ; break;}case 32:#line 203 "awk.y"{ yyval.nodeval = yyvsp[-2].nodeval; ; break;}case 33:#line 205 "awk.y"{ yyval.nodeval = yyvsp[0].nodeval; ; break;}case 34:#line 207 "awk.y"{ yyval.nodeval = node (yyvsp[-3].nodeval, Node_K_while, yyvsp[0].nodeval); ; break;}case 35:#line 209 "awk.y"{ yyval.nodeval = node (yyvsp[0].nodeval, Node_K_for, (NODE *)make_for_loop (yyvsp[-7].nodeval, yyvsp[-5].nodeval, yyvsp[-3].nodeval)); ; break;}case 36:#line 211 "awk.y"{ yyval.nodeval = node (yyvsp[0].nodeval, Node_K_for, (NODE *)make_for_loop (yyvsp[-6].nodeval, (NODE *)NULL, yyvsp[-3].nodeval)); ; break;}case 37:#line 213 "awk.y"{ yyval.nodeval = node (yyvsp[0].nodeval, Node_K_arrayfor, (NODE *)make_for_loop(variable(yyvsp[-6].sval), (NODE *)NULL, variable(yyvsp[-3].sval))); ; break;}case 38:#line 216 "awk.y"{ yyval.nodeval = node ((NODE *)NULL, Node_K_break, (NODE *)NULL); ; break;}case 39:#line 219 "awk.y"{ yyval.nodeval = node ((NODE *)NULL, Node_K_continue, (NODE *)NULL); ; break;}case 40:#line 221 "awk.y"{ ++want_redirect; ; break;}case 41:#line 223 "awk.y"{ want_redirect = 0; /* $4->lnode = NULL; */ yyval.nodeval = node (yyvsp[-2].nodeval, Node_K_print, yyvsp[-1].nodeval); ; break;}case 42:#line 229 "awk.y"{ ++want_redirect; ; break;}case 43:#line 231 "awk.y"{ want_redirect = 0; /* $4->lnode = NULL; */ yyval.nodeval = node (yyvsp[-2].nodeval, Node_K_printf, yyvsp[-1].nodeval); ; break;}case 44:#line 237 "awk.y"{ ++want_redirect; want_concat_token = 0; ; break;}case 45:#line 240 "awk.y"{ want_redirect = 0; yyval.nodeval = node (yyvsp[-4].nodeval, Node_K_printf, yyvsp[-1].nodeval); ; break;}case 46:#line 245 "awk.y"{ yyval.nodeval = node ((NODE *)NULL, Node_K_next, (NODE *)NULL); ; break;}case 47:#line 247 "awk.y"{ yyval.nodeval = node ((NODE *)NULL, Node_K_exit, (NODE *)NULL); ; break;}case 48:#line 249 "awk.y"{ yyval.nodeval = node (yyvsp[-2].nodeval, Node_K_exit, (NODE *)NULL); ; break;}case 49:#line 251 "awk.y"{ yyval.nodeval = yyvsp[-1].nodeval; ; break;}case 50:#line 257 "awk.y"{ yyval.nodeval = node (yyvsp[-3].nodeval, Node_K_if, node (yyvsp[0].nodeval, Node_if_branches, (NODE *)NULL)); ; break;}case 51:#line 261 "awk.y"{ yyval.nodeval = node (yyvsp[-6].nodeval, Node_K_if, node (yyvsp[-3].nodeval, Node_if_branches, yyvsp[0].nodeval)); ; break;}case 53:#line 268 "awk.y"{ yyval.nodetypeval = Node_illegal; ; break;}case 54:#line 273 "awk.y"{ yyval.nodeval = NULL; /* node (NULL, Node_redirect_nil, NULL); */ ; break;}case 55:#line 277 "awk.y"{ yyval.nodeval = node (yyvsp[0].nodeval, yyvsp[-1].nodetypeval, (NODE *)NULL); ; break;}case 56:#line 283 "awk.y"{ yyval.nodeval = NULL; /* node(NULL, Node_builtin, NULL); */ ; break;}case 57:#line 285 "awk.y"{ yyval.nodeval = yyvsp[0].nodeval; ; break;}case 58:#line 290 "awk.y"{ yyval.nodeval = NULL; ; break;}case 59:#line 292 "awk.y"{ yyval.nodeval = node (yyvsp[0].nodeval, Node_expression_list, (NODE *)NULL); ; break;}case 60:#line 294 "awk.y"{ yyval.nodeval = append_right(yyvsp[-2].nodeval, node( yyvsp[0].nodeval, Node_expression_list, (NODE *)NULL)); ; break;}case 61:#line 300 "awk.y"{ yyval.nodeval = snode (yyvsp[-1].nodeval, Node_builtin, yyvsp[-3].ptrval); ; break;}case 62:#line 302 "awk.y"{ yyval.nodeval = snode ((NODE *)NULL, Node_builtin, yyvsp[0].ptrval); ; break;}case 63:#line 304 "awk.y"{ yyval.nodeval = yyvsp[-1].nodeval; ; break;}case 64:#line 306 "awk.y"{ yyval.nodeval = node (yyvsp[0].nodeval, Node_unary_minus, (NODE *)NULL); ; break;}case 65:#line 308 "awk.y"{ yyval.nodeval = node (yyvsp[0].nodeval, Node_preincrement, (NODE *)NULL); ; break;}case 66:#line 310 "awk.y"{ yyval.nodeval = node (yyvsp[0].nodeval, Node_predecrement, (NODE *)NULL); ; break;}case 67:#line 312 "awk.y"{ yyval.nodeval = node (yyvsp[-1].nodeval, Node_postincrement, (NODE *)NULL); ; break;}case 68:#line 314 "awk.y"{ yyval.nodeval = node (yyvsp[-1].nodeval, Node_postdecrement, (NODE *)NULL); ; break;}case 69:#line 316 "awk.y"{ yyval.nodeval = yyvsp[0].nodeval; ; break;}case 70:#line 318 "awk.y"{ yyval.nodeval = make_number (yyvsp[0].fval); ; break;}case 71:#line 320 "awk.y"{ yyval.nodeval = make_string (yyvsp[0].sval, -1); ; break;}case 72:#line 324 "awk.y"{ yyval.nodeval = node (yyvsp[-2].nodeval, Node_times, yyvsp[0].nodeval); ; break;}case 73:#line 326 "awk.y"{ yyval.nodeval = node (yyvsp[-2].nodeval, Node_quotient, yyvsp[0].nodeval); ; break;}case 74:#line 328 "awk.y"{ yyval.nodeval = node (yyvsp[-2].nodeval, Node_mod, yyvsp[0].nodeval); ; break;}case 75:#line 330 "awk.y"{ yyval.nodeval = node (yyvsp[-2].nodeval, Node_plus, yyvsp[0].nodeval); ; break;}case 76:#line 332 "awk.y"{ yyval.nodeval = node (yyvsp[-2].nodeval, Node_minus, yyvsp[0].nodeval); ; break;}case 77:#line 335 "awk.y"{ yyval.nodeval = node (yyvsp[-2].nodeval, Node_concat, yyvsp[0].nodeval); ; break;}case 78:#line 337 "awk.y"{ yyval.nodeval = node (yyvsp[-2].nodeval, yyvsp[-1].nodetypeval, yyvsp[0].nodeval); ; break;}case 79:#line 341 "awk.y"{ yyval.nodeval = snode (yyvsp[-1].nodeval, Node_builtin, yyvsp[-3].ptrval); ; break;}case 80:#line 343 "awk.y"{ yyval.nodeval = snode ((NODE *)NULL, Node_builtin, yyvsp[0].ptrval); ; break;}case 81:#line 345 "awk.y"{ yyval.nodeval = yyvsp[-1].nodeval; ; break;}case 82:#line 347 "awk.y"{ yyval.nodeval = node (yyvsp[0].nodeval, Node_unary_minus, (NODE *)NULL); ; break;}case 83:#line 349 "awk.y"{ yyval.nodeval = node (yyvsp[0].nodeval, Node_preincrement, (NODE *)NULL); ; break;}case 84:#line 351 "awk.y"{ yyval.nodeval = node (yyvsp[0].nodeval, Node_predecrement, (NODE *)NULL); ; break;}case 85:#line 353 "awk.y"{ yyval.nodeval = node (yyvsp[-1].nodeval, Node_postincrement, (NODE *)NULL); ; break;}case 86:#line 355 "awk.y"{ yyval.nodeval = node (yyvsp[-1].nodeval, Node_postdecrement, (NODE *)NULL); ; break;}case 87:#line 357 "awk.y"{ yyval.nodeval = yyvsp[0].nodeval; ; break;}case 88:#line 359 "awk.y"{ yyval.nodeval = make_number (yyvsp[0].fval); ; break;}case 89:#line 361 "awk.y"{ yyval.nodeval = make_string (yyvsp[0].sval, -1); ; break;}case 90:#line 365 "awk.y"{ yyval.nodeval = node (yyvsp[-2].nodeval, Node_times, yyvsp[0].nodeval); ; break;}case 91:#line 367 "awk.y"{ yyval.nodeval = node (yyvsp[-2].nodeval, Node_quotient, yyvsp[0].nodeval); ; break;}case 92:#line 369 "awk.y"{ yyval.nodeval = node (yyvsp[-2].nodeval, Node_mod, yyvsp[0].nodeval); ; break;}case 93:#line 371 "awk.y"{ yyval.nodeval = node (yyvsp[-2].nodeval, Node_plus, yyvsp[0].nodeval); ; break;}case 94:#line 373 "awk.y"{ yyval.nodeval = node (yyvsp[-2].nodeval, Node_minus, yyvsp[0].nodeval); ; break;}case 95:#line 376 "awk.y"{ yyval.nodeval = node (yyvsp[-2].nodeval, Node_concat, yyvsp[0].nodeval); ; break;}case 96:#line 381 "awk.y"{ yyval.nodeval = variable (yyvsp[0].sval); ; break;}case 97:#line 383 "awk.y"{ yyval.nodeval = node (variable(yyvsp[-3].sval), Node_subscript, yyvsp[-1].nodeval); ; break;}case 98:#line 385 "awk.y"{ yyval.nodeval = node (yyvsp[0].nodeval, Node_field_spec, (NODE *)NULL); ; break;}} /*switch*/ /* the action file gets copied in in place of this dollarsign */#line 303 "bison.simple" yyvsp -= yylen; yylsp -= yylen; yyssp -= yylen; if (yydebug) { short *ssp1 = yyss - 1; fprintf (stderr, "state stack now", yyssp-yyss); while (ssp1 != yyssp) fprintf (stderr, " %d", *++ssp1); fprintf (stderr, "\n"); } *++yyvsp = yyval; yylsp++; if (yylen == 0) { yylsp->first_line = yylloc.first_line; yylsp->first_column = yylloc.first_column; yylsp->last_line = (yylsp-1)->last_line; yylsp->last_column = (yylsp-1)->last_column; yylsp->text = 0; } else { yylsp->last_line = (yylsp+yylen-1)->last_line; yylsp->last_column = (yylsp+yylen-1)->last_column; } /* Now "shift" the result of the reduction. Determine what state that goes to, based on the state we popped back to and the rule number reduced by. */ yyn = yyr1[yyn]; yystate = yypgoto[yyn - YYNTBASE] + *yyssp; if (yystate >= 0 && yystate <= YYLAST && yycheck[yystate] == *yyssp) yystate = yytable[yystate]; else yystate = yydefgoto[yyn - YYNTBASE]; goto yynewstate;yyerrlab: /* here on detecting error */ if (! yyerrstatus) /* If not already recovering from an error, report this error. */ { yyerror("parse error"); } if (yyerrstatus == 3) { /* if just tried and failed to reuse lookahead token after an error, discard it. */ /* return failure if at end of input */ if (yychar == YYEOF) YYERROR; if (yydebug) fprintf(stderr, "Discarding token %d (%s).\n", yychar, yytname[yychar1]); yychar = YYEMPTY; } /* Else will try to reuse lookahead token after shifting the error token. */ yyerrstatus = 3; /* Each real token shifted decrements this */ goto yyerrhandle;yyerrdefault: /* current state does not do anything special for the error token. */#if 0 /* This is wrong; only states that explicitly want error tokens should shift them. */ yyn = yydefact[yystate]; /* If its default is to accept any token, ok. Otherwise pop it.*/ if (yyn) goto yydefault;#endifyyerrpop: /* pop the current state because it cannot handle the error token */ if (yyssp == yyss) YYERROR; yyvsp--; yylsp--; yystate = *--yyssp; if (yydebug) { short *ssp1 = yyss - 1; fprintf (stderr, "Error: state stack now", yyssp-yyss); while (ssp1 != yyssp) fprintf (stderr, " %d", *++ssp1); fprintf (stderr, "\n"); }yyerrhandle: yyn = yypact[yystate]; if (yyn == YYFLAG) goto yyerrdefault; yyn += YYTERROR; if (yyn < 0 || yyn > YYLAST || yycheck[yyn] != YYTERROR) goto yyerrdefault; yyn = yytable[yyn]; if (yyn < 0) { if (yyn == YYFLAG) goto yyerrpop; yyn = -yyn; goto yyreduce; } else if (yyn == 0) goto yyerrpop; if (yyn == YYFINAL) YYACCEPT; if (yydebug) fprintf(stderr, "Shifting error token, "); *++yyvsp = yylval; *++yylsp = yylloc; yystate = yyn; goto yynewstate;}#line 388 "awk.y"struct token { char *operator; NODETYPE value; int class; NODE *(*ptr)();};#define NULL 0NODE *do_exp(), *do_getline(), *do_index(), *do_length(), *do_sqrt(), *do_log(), *do_sprintf(), *do_substr(), *do_split(), *do_int(); /* Special functions for debugging */#ifndef FASTNODE *do_prvars(), *do_bp();#endif/* Tokentab is sorted ascii ascending order, so it can be binary searched. *//* (later. Right now its just sort of linear search (SLOW!!) */static struct token tokentab[] = { {"BEGIN", Node_illegal, LEX_BEGIN, 0}, {"END", Node_illegal, LEX_END, 0},#ifndef FAST {"bp", Node_builtin, LEX_BUILTIN, do_bp},#endif {"break", Node_K_break, LEX_BREAK, 0}, {"continue", Node_K_continue, LEX_CONTINUE, 0}, {"else", Node_illegal, LEX_ELSE, 0}, {"exit", Node_K_exit, LEX_EXIT, 0}, {"exp", Node_builtin, LEX_BUILTIN, do_exp}, {"for", Node_K_for, LEX_FOR, 0}, {"getline", Node_builtin, LEX_BUILTIN, do_getline}, {"if", Node_K_if, LEX_IF, 0}, {"in", Node_illegal, LEX_IN, 0}, {"index", Node_builtin, LEX_BUILTIN, do_index}, {"int", Node_builtin, LEX_BUILTIN, do_int}, {"length", Node_builtin, LEX_BUILTIN, do_length}, {"log", Node_builtin, LEX_BUILTIN, do_log}, {"next", Node_K_next, LEX_NEXT, 0}, {"print", Node_K_print, LEX_PRINT, 0}, {"printf", Node_K_printf, LEX_PRINTF, 0},#ifndef FAST {"prvars", Node_builtin, LEX_BUILTIN, do_prvars},#endif {"split", Node_builtin, LEX_BUILTIN, do_split}, {"sprintf", Node_builtin, LEX_BUILTIN, do_sprintf}, {"sqrt", Node_builtin, LEX_BUILTIN, do_sqrt}, {"substr", Node_builtin, LEX_BUILTIN, do_substr}, {"while", Node_K_while, LEX_WHILE, 0}, {NULL, Node_illegal, ERROR, 0}};/* Read one token, getting characters through lexptr. */static intyylex (){ register1 int c; register1 int namelen; register1 char *tokstart; register1 struct token *toktab; double atof(); /* JF know what happens if you forget this? */ static did_newline = 0; /* JF the grammar insists that actions end with newlines. This was easier than hacking the grammar. */ int do_concat; int seen_e = 0; /* These are for numbers */ int seen_point = 0; retry: if(!lexptr) return 0; if (want_regexp) { want_regexp = 0; /* there is a potential bug if a regexp is followed by an equal sign: "/foo/=bar" would result in assign_quotient being returned as the next token. Nothing is done about it since it is not valid awk, but maybe something should be done anyway. */ tokstart = lexptr; while (c = *lexptr++) { switch (c) { case '\\': if (*lexptr++ == '\0') { yyerror ("unterminated regexp ends with \\"); return ERROR; } break; case '/': /* end of the regexp */ lexptr--; yylval.sval = tokstart; return REGEXP; case '\n': case '\0': yyerror ("unterminated regexp"); return ERROR; } } } do_concat=want_concat_token; want_concat_token=0; if(*lexptr=='\0') { lexptr=0; return NEWLINE; } /* if lexptr is at white space between two terminal tokens or parens, it is a concatenation operator. */ if(do_concat && (*lexptr==' ' || *lexptr=='\t')) { while (*lexptr == ' ' || *lexptr == '\t') lexptr++; if (isalnum(*lexptr) || *lexptr == '\"' || *lexptr == '(' || *lexptr == '.' || *lexptr == '$') /* the '.' is for decimal pt */ return CONCAT_OP; } while (*lexptr == ' ' || *lexptr == '\t') lexptr++; tokstart = lexptr; /* JF */ switch (c = *lexptr++) { case 0: return 0; case '\n': lineno++; return NEWLINE; case '#': /* it's a comment */ while (*lexptr != '\n' && *lexptr != '\0') lexptr++; goto retry; case '\\': if(*lexptr=='\n') { lexptr++; goto retry; } else break; case ')': case ']': ++want_concat_token; /* fall through */ case '(': /* JF these were above, but I don't see why they should turn on concat. . . &*/ case '[': case '{': case ',': /* JF */ case '$': case ';': /* set node type to ILLEGAL because the action should set it to the right thing */ yylval.nodetypeval = Node_illegal; return c; case '*': if(*lexptr=='=') { yylval.nodetypeval=Node_assign_times; lexptr++; return ASSIGNOP; } yylval.nodetypeval=Node_illegal; return c; case '/': if(*lexptr=='=') { yylval.nodetypeval=Node_assign_quotient; lexptr++; return ASSIGNOP; } yylval.nodetypeval=Node_illegal; return c; case '%': if(*lexptr=='=') { yylval.nodetypeval=Node_assign_mod; lexptr++; return ASSIGNOP; } yylval.nodetypeval=Node_illegal; return c; case '+': if(*lexptr=='=') { yylval.nodetypeval=Node_assign_plus; lexptr++; return ASSIGNOP; } if(*lexptr=='+') { yylval.nodetypeval=Node_illegal; lexptr++; return INCREMENT; } yylval.nodetypeval=Node_illegal; return c; case '!': if(*lexptr=='=') { yylval.nodetypeval=Node_notequal; lexptr++; return RELOP;
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:gawk ƒ:awk.tab.c
+++++ Continued from previous card +++++
} if(*lexptr=='~') { yylval.nodetypeval=Node_nomatch; lexptr++; return MATCHOP; } yylval.nodetypeval=Node_illegal; return c; case '<': if(*lexptr=='=') { yylval.nodetypeval=Node_leq; lexptr++; return RELOP; } yylval.nodetypeval=Node_less; return RELOP; case '=': if(*lexptr=='=') { yylval.nodetypeval=Node_equal; lexptr++; return RELOP; } yylval.nodetypeval=Node_assign; return ASSIGNOP; case '>': if(want_redirect) { if (*lexptr == '>') { yylval.nodetypeval = Node_redirect_append; lexptr++; } else yylval.nodetypeval = Node_redirect_output; return REDIRECT_OP; } if(*lexptr=='=') { yylval.nodetypeval=Node_geq; lexptr++; return RELOP; } yylval.nodetypeval=Node_greater; return RELOP; case '~': yylval.nodetypeval=Node_match; return MATCHOP; case '}': /* JF added did newline stuff. Easier than hacking the grammar */ if(did_newline) { did_newline=0; return c; } did_newline++; --lexptr; return NEWLINE; case '"': while (*lexptr != '\0') { switch (*lexptr++) { case '\\': if (*lexptr++ != '\0') /* fall through */ case '\n': yyerror ("unterminated string"); return ERROR; case '\"': yylval.sval = tokstart + 1; /* JF Skip the doublequote */ ++want_concat_token; return YSTRING; } } return ERROR; /* JF this was one level up, wrong? */ case '-': if(*lexptr=='=') { yylval.nodetypeval=Node_assign_minus; lexptr++; return ASSIGNOP; } if(*lexptr=='-') { yylval.nodetypeval=Node_illegal; lexptr++; return DECREMENT; } /* JF I think space tab comma and newline are the legal places for a UMINUS. Have I missed any? */ if((!isdigit(*lexptr) && *lexptr!='.') || (lexptr>lexptr_begin+1 && !index(" \t,\n",lexptr[-2]))) { /* set node type to ILLEGAL because the action should set it to the right thing */ yylval.nodetypeval = Node_illegal; return c; } /* FALL through into number code */ case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': case '.': /* It's a number */ if(c=='-') namelen=1; else namelen=0; for (; (c = tokstart[namelen]) != '\0'; namelen++) { switch (c) { case '.': if (seen_point) goto got_number; ++seen_point; break; case 'e': case 'E': if (seen_e) goto got_number; ++seen_e; if (tokstart[namelen+1] == '-' || tokstart[namelen+1] == '+') namelen++; break; case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': break; default: goto got_number; } }got_number: lexptr = tokstart + namelen; yylval.fval = atof(tokstart); ++want_concat_token; return NUMBER; case '&': if(*lexptr=='&') { yylval.nodetypeval=Node_and; lexptr++; return LEX_AND; } return ERROR; case '|': if(want_redirect) { lexptr++; yylval.nodetypeval = Node_redirect_pipe; return REDIRECT_OP; } if(*lexptr=='|') { yylval.nodetypeval=Node_or; lexptr++; return LEX_OR; } return ERROR; } if (!isalpha(c)) { yyerror ("Invalid char '%c' in expression\n", c); return ERROR; } /* its some type of name-type-thing. Find its length */ for (namelen = 0; is_identchar(tokstart[namelen]); namelen++) ; /* See if it is a special token. */ for (toktab = tokentab; toktab->operator != NULL; toktab++) { if(*tokstart==toktab->operator[0] && !strncmp(tokstart,toktab->operator,namelen) && toktab->operator[namelen]=='\0') { lexptr=tokstart+namelen; if(toktab->class == LEX_BUILTIN) yylval.ptrval = toktab->ptr; else yylval.nodetypeval = toktab->value; return toktab->class; } } /* It's a name. See how long it is. */ yylval.sval = tokstart; lexptr = tokstart+namelen; ++want_concat_token; return NAME;}/*VARARGS1*/yyerror (mesg,a1,a2,a3,a4,a5,a6,a7,a8) char *mesg;{ register1 char *ptr,*beg; /* Find the current line in the input file */ if(!lexptr) { beg="(END OF FILE)"; ptr=beg+13; } else { if (*lexptr == '\n' && lexptr!=lexptr_begin) --lexptr; for (beg = lexptr;beg!=lexptr_begin && *beg != '\n';--beg) ; for (ptr = lexptr;*ptr && *ptr != '\n';ptr++) /*jfw: NL isn't guaranteed*/ ; if(beg!=lexptr_begin) beg++; } fprintf (stderr, "Error near line %d, '%.*s'\n",lineno, ptr-beg, beg); /* figure out line number, etc. later */ fprintf (stderr, mesg, a1, a2, a3, a4, a5, a6, a7, a8); fprintf (stderr,"\n"); exit (1);}/* Parse a C escape sequence. STRING_PTR points to a variable containing a pointer to the string to parse. That pointer is updated past the characters we use. The value of the escape sequence is returned. A negative value means the sequence \ newline was seen, which is supposed to be equivalent to nothing at all. If \ is followed by a null character, we return a negative value and leave the string pointer pointing at the null character. If \ is followed by 000, we return 0 and leave the string pointer after the zeros. A value of 0 does not mean end of string. */static intparse_escape (string_ptr) char **string_ptr;{ register1 int c = *(*string_ptr)++; switch (c) { case 'a': return '\a'; case 'b': return '\b'; case 'e': return 033; case 'f': return '\f'; case 'n': return '\n'; case 'r': return '\r'; case 't': return '\t'; case 'v': return '\v'; case '\n': return -2; case 0: (*string_ptr)--; return 0; case '^': c = *(*string_ptr)++; if (c == '\\') c = parse_escape (string_ptr); if (c == '?') return 0177; return (c & 0200) | (c & 037); case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': { register1 int i = c - '0'; register1 int count = 0; while (++count < 3) { if ((c = *(*string_ptr)++) >= '0' && c <= '7') { i *= 8; i += c - '0'; } else { (*string_ptr)--; break; } } return i; } default: return c; }} :MPW:MPW Tools:Tools with Source:gawk ƒ:awk1.c
#define register1/* * awk1 -- Expression tree constructors and main program for gawk. * * Copyright (C) 1986 Free Software Foundation * Written by Paul Rubin, August 1986 * *//*GAWK is distributed in the hope that it will be useful, but WITHOUT ANYWARRANTY. No author or distributor accepts responsibility to anyonefor the consequences of using it or for whether it serves anyparticular purpose or works at all, unless he says so in writing.Refer to the GAWK General Public License for full details.Everyone is granted permission to copy, modify and redistribute GAWK,but only under the conditions described in the GAWK General PublicLicense. A copy of this license is supposed to have been given to youalong with GAWK so you can know your rights and responsibilities. Itshould be in a file named COPYING. Among other things, the copyrightnotice and this notice must be preserved on all copies.In other words, go ahead and share GAWK, but don't try to stopanyone else from sharing it farther. Help stamp out software hoarding!*/#include <stdio.h>#include <string.h>#include "regex.h"#include "awk.h"/* Temporary nodes are stored here. ob_dummy is a dummy object used to keep the obstack library from free()ing up the entire stack. */struct obstack temp_strings;char *ob_dummy;/* The parse tree and field nodes are stored here. Parse_end is a dummy item used to free up unneeded fields without freeing the program being run */struct obstack other_stack;char *parse_end;/* The global null string */NODE *Nnull_string;/* The special variable that contains the name of the current input file */extern NODE *FILENAME_node;/* The name the program was invoked under, for error messages */char *myname;/* A block of gAWK code to be run before running the program */NODE *begin_block = 0;/* A block of gAWK code to be run after the last input file */NODE *end_block = 0;FILE *input_file; /* Where to read from */#ifndef FAST/* non-zero means in debugging is enabled. Probably not very useful */int debugging;#endifchar *index();void print_parse_tree();void dbprint(no) int no; {char ssdbx[20]; printf("debug no = %d\n",no); scanf("%s",ssdbx); if (strcmp(ssdbx,"stop") ) {return;} else {exit(1);} } main(argc, argv) int argc; char **argv;{ register1 int i; register1 NODE *tmp; char **do_vars;#ifndef FAST /* Print out the parse tree. For debugging */ register1 int dotree = 0; extern int yydebug;#endif extern char *lexptr; extern char *lexptr_begin; FILE *fp,*fopen(); char ssxdbg[40]; --argc; myname= *argv++; if(!argc) usage(); /* Tell the regex routines how they should work. . . */ re_set_syntax(RE_NO_BK_PARENS|RE_NO_BK_VBAR); /* Set up the stack for temporary strings */ obstack_init (&temp_strings); ob_dummy=obstack_alloc(&temp_strings,0); /* Set up the other stack for other things */ obstack_init(&other_stack); /* initialize the null string */ Nnull_string = make_string("",0); /* This was to keep Nnull_string from ever being free()d It didn't work */ /* Nnull_string->stref=32000; */ /* Set up the special variables */ /* Note that this must be done BEFORE arg parsing else -R and -F break horribly */ init_vars(); for(;*argv && **argv=='-';argc--,argv++) { switch(argv[0][1]) {#ifndef FAST case 'd': debugging++; dotree++; break; case 'D': debugging++; yydebug=2; break;#endif /* This feature isn't in un*x awk, but might be useful */ case 'R': set_rs(&argv[0][2]); break; case 'F': set_fs(&argv[0][2]); break; /* It would be better to read the input file in as we parse it. Its done this way for hysterical reasons. Feel free to fix it. */ case 'f': if(lexptr) panic("Can only use one -f option"); if((fp=fopen(argv[1],"r"))==NULL) er_panic(argv[1]); else { char *curptr; int siz,nread; curptr=lexptr=malloc(2000); if(curptr==NULL) panic("Memory exhausted"); /* jfw: instead of abort() */ siz=2000; i=siz-1; while((nread=fread(curptr,sizeof(char),i,fp)) > 0) { curptr+=nread; i-=nread; if(i==0) { lexptr=realloc(lexptr,siz*2); if(lexptr==NULL) panic("Memory exhausted"); /* jfw: instead of abort() */ curptr=lexptr+siz-1; i=siz; siz*=2; } } *curptr='\0'; for (curptr=lexptr;*curptr != '\0';curptr++) {if (*curptr == '\r') *curptr='\n';} fclose(fp); } argc--; argv++; break; case 'v': { extern char *version_string; fprintf(stderr,"%s\n",version_string); } break; case '\0': /* A file */ break; default: panic("Unknown option %s",argv[0]); } }#ifndef FAST if (debugging) setbuf(stdout, 0); /* jfw: make debugging easier */#endif /* No -f option, use next arg */ if(!lexptr) { if(!argc) usage(); lexptr= *argv++; --argc; } /* Read in the program */ lexptr_begin=lexptr; (void)yyparse (); /* Anything allocated on the other_stack after here will be freed when the next input line is read. */ parse_end=obstack_alloc(&other_stack,0); #ifndef FAST if(dotree) print_parse_tree(expression_value);#endif /* Set up the field variables */ init_fields(); /* Look for BEGIN and END blocks. Only one of each allowed */ for(tmp=expression_value;tmp;tmp=tmp->rnode) { if(!tmp->lnode || !tmp->lnode->lnode) continue; if(tmp->lnode->lnode->type==Node_K_BEGIN) begin_block=tmp->lnode->rnode; else if(tmp->lnode->lnode->type==Node_K_END) end_block=tmp->lnode->rnode; } if(begin_block && interpret(begin_block) == 0) exit(0); /* jfw */ do_vars=argv; while(argc>0 && index(*argv,'=')) { argv++; --argc; } if(do_vars==argv) do_vars=0; if(argc==0) { static char *dumb[2]= { "-", 0}; argc=1; argv= &dumb[0]; } while(argc--) { if(!strcmp(*argv,"-")) { input_file=stdin; FILENAME_node->var_value=Nnull_string; ADD_ONE_REFERENCE(Nnull_string); } else { extern NODE *deref; input_file=fopen(*argv,"r"); /* This should print the error message from errno */ if(!input_file) er_panic(*argv); /* This is a kludge. */ deref=FILENAME_node->var_value; do_deref(); FILENAME_node->var_value=make_string(*argv,strlen(*argv)); } /* This is where it spends all its time. The infamous MAIN LOOP */ if(inrec()==0) { if(do_vars) { while(do_vars!=argv && *do_vars) { char *cp; cp=index(*do_vars,'='); *cp++='\0'; variable(*do_vars)->var_value=make_string(cp,strlen(cp)); do_vars++; } do_vars=0; } do obstack_free(&temp_strings, ob_dummy); while (interpret(expression_value) && inrec() == 0); } if(input_file!=stdin) fclose(input_file); argv++; } if(end_block) (void)interpret(end_block); exit(0);}/* These exit values are arbitrary *//*VARARGS1*/panic(str,arg)char *str;{ fprintf(stderr,"%s: ",myname); fprintf(stderr,str,arg); fprintf(stderr,"\n"); exit(12);}er_panic(str)char *str;{ fprintf(stderr,"%s: ",myname); perror(str); exit(15);}usage(){ fprintf(stderr,"%s:\n usage: %s {-f progfile | program } [-F{c} -R{c}] file . . .\n",myname,myname); exit(11);}/* This allocates a new node of type ty. Note that this node will not go away unless freed, so don't use it for tmp storage */NODE *newnode(ty)NODETYPE ty;{ register1 NODE *r; r=(NODE *)malloc(sizeof(NODE)); if(r==NULL) abort(); r->type=ty; return r;}/* Duplicate a node. (For global strings, "duplicate" means crank up the reference count.) This creates global nodes. . .*/NODE *dupnode(n)NODE *n;{ register1 NODE *r; if(n->type==Node_string) { n->stref++; return n; } else if(n->type==Node_temp_string) { r=newnode(Node_string); r->stlen=n->stlen; r->stref=1; r->stptr=malloc(n->stlen+1); if(r->stptr==NULL) abort(); bcopy (n->stptr, r->stptr, n->stlen); r->stptr[r->stlen]='\0'; /* JF for hackval */ return r; } else { r=newnode(Node_illegal); *r= *n; return r; }}/* This allocates a node with defined lnode and rnode. *//* This should only be used by yyparse+co while reading in the program */NODE *node (left, op, right) NODE *left, *right; NODETYPE op;{ register1 NODE *r; r = (NODE *)obstack_alloc(&other_stack,sizeof(NODE)); r->type=op; r->lnode = left; r->rnode = right; return r;}/* This allocates a node with defined subnode and proc *//* Otherwise like node() */NODE *snode(subn, op, procp)NODETYPE op;NODE *(*procp)();NODE *subn;{ register1 NODE *r; r=(NODE *)obstack_alloc(&other_stack,sizeof(NODE)); r->type=op; r->subnode=subn; r->proc=procp; return r;}/* (jfw) This allocates a Node_line_range node * with defined condpair and zeroes the trigger word * to avoid the temptation of assuming that calling * 'node( foo, Node_line_range, 0)' will properly initialize 'triggered'. *//* Otherwise like node() */NODE *mkrangenode(cpair)NODE *cpair;{ register1 NODE *r; r=(NODE *)obstack_alloc(&other_stack,sizeof(NODE)); r->type=Node_line_range; r->condpair=cpair; r->triggered = 0; return r;}/* this allocates a node with defined numbr *//* This creates global nodes! */NODE *make_number (x) AWKNUM x;{ register1 NODE *r; r=newnode(Node_number); r->numbr = x; return r;}/* This creates temporary nodes. They go away quite quicly, so don't use them for anything important */#ifndef FASTNODE *tmp_number(x)AWKNUM x;{#ifdef DONTDEF return make_number(x);#endif NODE *r; r=(NODE *)obstack_alloc(&temp_strings,sizeof(NODE)); r->type=Node_number; r->numbr=x; return r;}#endif/* Make a string node. If len==0, the string passed in S is supposed to end with a double quote, but have had the beginning double quote already stripped off by yylex. If LEN!=0, we don't care what s ends with. This creates a global node */NODE *make_string (s,len) char *s; int len;{ register1 NODE *r; register1 char *pf,*pt; register1 int c; /* the aborts are impossible because yylex is supposed to have already checked for unterminated strings */ if(len==-1) { /* Called from yyparse, find our own len */#ifndef FAST if (s[-1] != '\"') /* Didn't start with " */ abort ();#endif for(pf = pt = s; *pf != '\0' && *pf!='\"';) { c= *pf++; switch(c) {#ifndef FAST case '\0': abort();#endif case '\\':#ifndef FAST if(*pf=='\0') abort();#endif c= *pf++; switch(c) { case '\\': /* no massagary needed */ case '\'': case '\"': break; case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': c-='0'; while(*pf && *pf>='0' && *pf<='7') { c=c*8+ *pf++ - '0'; } break; case 'b': c='\b'; break; case 'f': c='\f'; break; case 'n': c='\n'; break; case 'r': c='\r'; break; case 't': c='\t'; break; case 'v': c='\v'; break; default: *pt++='\\'; break; } /* FALL THROUGH */ default: *pt++=c; break; } }#ifndef FAST if(*pf=='\0') abort(); /* JF hit the end of the buf */#endif len = pt - s; /* JF was p - s - 1 */ } r=newnode(Node_string); r->stptr=(char *)malloc(len+1); if(r->stptr==0) abort(); r->type=Node_string; r->stlen=len; r->stref=1; bcopy (s, r->stptr, len); r->stptr[len]='\0'; /* JF a hack */ return r;}/* #ifndef FAST *//* This should be a macro for speed, but the C compiler chokes. *//* Read the warning under tmp_number */NODE *tmp_string(s,len)char *s;{ register1 NODE *r;#ifdef DONTDEF return make_string(s,len);#endif r=(NODE *)obstack_alloc(&temp_strings,sizeof(NODE)); r->stptr=(char *)obstack_alloc(&temp_strings,len+1); r->type=Node_temp_string; r->stlen=len; r->stref=1; bcopy (s, r->stptr, len); r->stptr[len]='\0'; /* JF a hack */ return r;}/* #endif *//* Generate compiled regular expressions */struct re_pattern_buffer *make_regexp (s) char *s;{ typedef struct re_pattern_buffer RPAT; RPAT *rp; char *p, *err; rp = (RPAT *) obstack_alloc(&other_stack, sizeof (RPAT)); bzero((char *)rp,sizeof(RPAT)); rp->buffer = (char *)malloc(8); /* JF I'd obstack allocate it, except the regex routines try to realloc() it, which fails. */ /* Note that this means it may never be freed. Someone fix, please? */ rp->allocated = 8; rp->fastmap = (char *)obstack_alloc(&other_stack, 256); for (p = s; *p != '\0'; p++) { if (*p == '\\') p++; else if (*p == '/') break; }#ifndef FAST if (*p != '/') abort (); /* impossible */#endif /* JF was re_compile_pattern, but that mishandles ( ) and |, so I had to write my own front end. Sigh. */ if ((err = re_compile_pattern (s, p - s, rp)) != NULL) { fprintf (stderr, "illegal regexp: "); yyerror (err); /* fatal */ } return rp;}/* Build a for loop */FOR_LOOP_HEADER *make_for_loop (init, cond, incr) NODE *init, *cond, *incr;{ register1 FOR_LOOP_HEADER *r; r = (FOR_LOOP_HEADER *)obstack_alloc(&other_stack,sizeof (FOR_LOOP_HEADER)); r->init = init; r->cond = cond; r->incr = incr; return r;}/* Name points to a variable name. Make sure its in the symbol table */NODE *variable (name) char *name;{ register1 NODE *r; NODE *lookup(), *install(); if ((r = lookup (variables, name)) == NULL) { r = install (variables, name, node(Nnull_string, Node_var, (NODE *)NULL)); /* JF make_number (0.0) is WRONG */ } return r;}/* Create a special variable */NODE *spc_var (name,value)char *name;NODE *value;{ register1 NODE *r; NODE *lookup(), *install(); if ((r = lookup(variables, name)) == NULL) r = install (variables, name, node(value, Node_var, (NODE *)NULL)); return r;}/* * Install a name in the hash table specified, even if it is already there. * Name stops with first non alphanumeric. * Caller must check against redefinition if that is desired. */NODE *install (table, name, value) HASHNODE **table; char *name; NODE *value;{ register1 HASHNODE *hp; register1 int i, len, bucket; register1 char *p; len = 0; p = name; while (is_identchar(*p)) p++; len = p - name; i = sizeof (HASHNODE) + len + 1; hp = (HASHNODE *)obstack_alloc(&other_stack,i); bucket = hashf(name, len, HASHSIZE); hp->next = table[bucket]; table[bucket] = hp; hp->length = len; hp->value = value; hp->name = ((char *) hp) + sizeof (HASHNODE); hp->length = len; bcopy (name, hp->name, len); return hp->value;}/* * find the most recent hash node for name name (ending with first * non-identifier char) installed by install */NODE *lookup (table, name) HASHNODE **table; char *name;{ register1 char *bp; register1 HASHNODE *bucket; register1 int len; for (bp = name; is_identchar(*bp); bp++) ; len = bp - name; bucket = table[hashf(name, len, HASHSIZE)]; while (bucket) { if (bucket->length == len && strncmp(bucket->name, name, len) == 0) return bucket->value; bucket = bucket->next; } return NULL;}#define HASHSTEP(old, c) ((old << 1) + c)#define MAKE_POS(v) (v & ~0x80000000) /* make number positive *//* * return hash function on name. must be compatible with the one * computed a step at a time, elsewhere (JF: Where? I can't find it!) */inthashf(name, len, hashsize) register1 char *name; register1 int len; int hashsize;{ register1 int r = 0; while (len--) r = HASHSTEP(r, *name++); return MAKE_POS(r) % hashsize;
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:gawk ƒ:awk1.c
+++++ Continued from previous card +++++
}/* Add new to the rightmost branch of LIST. This uses n^2 time, but doesn't get used enough to make optimizing worth it. . . *//* You don't believe me? Profile it yourself! */NODE *append_right(list,new)NODE *list,*new;{ register1 NODE *oldlist; oldlist = list; while(list->rnode!=NULL) list=list->rnode; list->rnode = new; return oldlist;} :MPW:MPW Tools:Tools with Source:gawk ƒ:awk2.c
#define register1 /* * awk2 --- gawk parse tree interpreter * * Copyright (C) 1986 Free Software Foundation * Written by Paul Rubin, August 1986 * *//*GAWK is distributed in the hope that it will be useful, but WITHOUT ANYWARRANTY. No author or distributor accepts responsibility to anyonefor the consequences of using it or for whether it serves anyparticular purpose or works at all, unless he says so in writing.Refer to the GAWK General Public License for full details.Everyone is granted permission to copy, modify and redistribute GAWK,but only under the conditions described in the GAWK General PublicLicense. A copy of this license is supposed to have been given to youalong with GAWK so you can know your rights and responsibilities. Itshould be in a file named COPYING. Among other things, the copyrightnotice and this notice must be preserved on all copies.In other words, go ahead and share GAWK, but don't try to stopanyone else from sharing it farther. Help stamp out software hoarding!*/#include <setjmp.h>#include <stdio.h>#include <string.h>/* #ifdef SYSV *//* nasty nasty berkelixm */#define _setjmp setjmp#define _longjmp longjmp/* #endif */#include "awk.h"void dbprint();NODE **get_lhs();extern NODE dumb[],*OFMT_node;/* BEGIN and END blocks need special handling, because we are handed them * as raw Node_statement_lists, not as Node_rule_lists (jfw) */extern NODE *begin_block, *end_block;NODE *do_sprintf();extern struct obstack other_stack;#define min(a,b) ((a) < (b) ? (a) : (b))/* More of that debugging stuff */#ifdef FAST#define DEBUG(X)#else#define DEBUG(X) print_debug X#endif/* longjmp return codes, must be nonzero *//* Continue means either for loop/while continue, or next input record */#define TAG_CONTINUE 1/* Break means either for/while break, or stop reading input */#define TAG_BREAK 2/* the loop_tag_valid variable allows continue/break-out-of-context * to be caught and diagnosed (jfw) */#define PUSH_BINDING(stack, x) (bcopy ((char *)(x), (char *)(stack), sizeof (jmp_buf)), loop_tag_valid++)#define RESTORE_BINDING(stack, x) (bcopy ((char *)(stack), (char *)(x), sizeof (jmp_buf)), loop_tag_valid--)/* for "for(iggy in foo) {" */struct search { int numleft; AHASH **arr_ptr; AHASH *bucket; NODE *symbol; NODE *retval;};struct search *assoc_scan(),*assoc_next();/* Tree is a bunch of rules to run. Returns zero if it hit an exit() statement */interpret (tree) NODE *tree;{ register1 NODE *t; /* temporary */ auto jmp_buf loop_tag_stack; /* shallow binding stack for loop_tag */ static jmp_buf loop_tag; /* always the current binding */ static int loop_tag_valid = 0;/* nonzero when loop_tag valid (jfw) */ static jmp_buf rule_tag; /* tag the rule currently being run, for NEXT and EXIT statements. It is static because there are no nested rules */ register1 NODE **lhs; /* lhs == Left Hand Side for assigns, etc */ register1 struct search *l; /* For array_for */ extern struct obstack temp_strings; extern char *ob_dummy; NODE *do_printf(); /* clean up temporary strings created by evaluating expressions in previous recursive calls */ obstack_free (&temp_strings, ob_dummy); if(tree == NULL) return 1; switch (tree->type) {#ifndef FAST /* Can't run these! */ case Node_illegal: case Node_rule_node: case Node_if_branches: case Node_expression_list: case Node_K_BEGIN: case Node_K_END: case Node_redirect_output: case Node_redirect_append: case Node_redirect_pipe: case Node_var_array: abort();#endif case Node_rule_list: for (t = tree; t != NULL; t = t->rnode) { switch (_setjmp(rule_tag)) { case 0: /* normal non-jump */ if (eval_condition (t->lnode->lnode)) { DEBUG(("Found a rule",t->lnode->rnode)); if (t->lnode->rnode == NULL) { /* special case: pattern with no action is equivalent to * an action of {print} (jfw) */ NODE printnode; printnode.type = Node_K_print; printnode.lnode = NULL; printnode.rnode = NULL; hack_print_node(&printnode); } else { (void)interpret (t->lnode->rnode);} } break; case TAG_CONTINUE: /* NEXT statement */ return 1; case TAG_BREAK: return 0; } } break; case Node_statement_list: /* print_a_node(tree); */ /* because BEGIN and END do not have Node_rule_list nature, yet can * have exits and nexts, we special-case a setjmp of rule_tag here. * (jfw) */ if (tree == begin_block || tree == end_block) { switch (_setjmp(rule_tag)) { case TAG_CONTINUE: /* next */ panic("unexpected next"); return 1; case TAG_BREAK: return 0; } } for (t = tree; t != NULL; t = t->rnode) { DEBUG(("Statements",t->lnode)); (void)interpret (t->lnode); } break; case Node_K_if: DEBUG(("IF",tree->lnode)); if (eval_condition(tree->lnode)) { DEBUG(("True",tree->rnode->lnode)); (void)interpret (tree->rnode->lnode); } else { DEBUG(("False",tree->rnode->rnode)); (void)interpret (tree->rnode->rnode); } break; case Node_K_while: PUSH_BINDING (loop_tag_stack, loop_tag); DEBUG(("WHILE",tree->lnode)); while (eval_condition (tree->lnode)) { switch (_setjmp (loop_tag)) { case 0: /* normal non-jump */ DEBUG(("DO",tree->rnode)); (void)interpret (tree->rnode); break; case TAG_CONTINUE: /* continue statement */ break; case TAG_BREAK: /* break statement */ RESTORE_BINDING (loop_tag_stack, loop_tag); return 1;#ifndef FAST default: abor* never happens */#endif } } RESTORE_BINDING (loop_tag_stack, loop_tag); break; case Node_K_for: PUSH_BINDING (loop_tag_stack, loop_tag); DEBUG(("FOR",tree->forloop->init)); (void)interpret (tree->forloop->init); DEBUG(("FOR.WHILE",tree->forloop->cond)); while (eval_condition (tree->forloop->cond)) { switch (_setjmp (loop_tag)) { case 0: /* normal non-jump */ DEBUG(("FOR.DO",tree->lnode)); (void)interpret (tree->lnode); /* fall through */ case TAG_CONTINUE: /* continue statement */ DEBUG(("FOR.INCR",tree->forloop->incr)); (void)interpret (tree->forloop->incr); break; case TAG_BREAK: /* break statement */ RESTORE_BINDING (loop_tag_stack, loop_tag); return 1;#ifndef FAST default: abort (); /* never happens */#endif } } RESTORE_BINDING (loop_tag_stack, loop_tag); break; case Node_K_arrayfor:#define hakvar forloop->init#define arrvar forloop->incr PUSH_BINDING(loop_tag_stack, loop_tag); DEBUG(("AFOR.VAR",tree->hakvar)); lhs=get_lhs(tree->hakvar); do_deref(); for(l=assoc_scan(tree->arrvar);l;l=assoc_next(l)) { *lhs=dupnode(l->retval); DEBUG(("AFOR.NEXTIS",*lhs)); switch(_setjmp(loop_tag)) { case 0: DEBUG(("AFOR.DO",tree->lnode)); (void)interpret(tree->lnode); case TAG_CONTINUE: break; case TAG_BREAK: RESTORE_BINDING(loop_tag_stack, loop_tag); return 1;#ifndef FAST default: abort();#endif } } RESTORE_BINDING(loop_tag_stack, loop_tag); break; case Node_K_break: DEBUG(("BREAK",NULL)); if (loop_tag_valid == 0) /* jfw */ panic("unexpected break or continue"); _longjmp (loop_tag, TAG_BREAK); break; case Node_K_continue: DEBUG(("CONTINUE",NULL)); if (loop_tag_valid == 0) /* jfw */ panic("unexpected break or continue"); _longjmp (loop_tag, TAG_CONTINUE); break; case Node_K_print: DEBUG(("PRINT",tree)); (void)hack_print_node (tree); break; case Node_K_printf: DEBUG(("PRINTF",tree)); (void)do_printf(tree); break; case Node_K_next: DEBUG(("NEXT",NULL)); _longjmp (rule_tag, TAG_CONTINUE); break; case Node_K_exit: /* The unix awk doc says to skip the rest of the input. Does that mean after performing all the rules on the current line? Unix awk quits immediately, so t too. */ /* The UN*X exit can also take an optional arg return code. We don't */ /* Well, we parse it, but never *DO* it */ DEBUG(("EXIT",NULL)); _longjmp (rule_tag, TAG_BREAK); break; default: /* Appears to be an expression statement. Throw away the value. */ DEBUG(("E",NULL)); (void)tree_eval (tree); break; } return 1;}/* evaluate a subtree, allocating strings on a temporary stack. *//* This used to return a whole NODE, instead of a ptr to one, but that led to lots of obnoxious copying. I got rid of it (JF) */NODE *tree_eval (tree) NODE *tree;{ register1 NODE *r, *t1, *t2; /* return value and temporary subtrees */ register1 NODE **lhs; static AWKNUM x; /* Why are these static? */ extern struct obstack temp_strings; if(tree == NULL) { DEBUG(("NULL",NULL)); return Nnull_string; } switch (tree->type) { /* trivial data */ case Node_string: case Node_number: DEBUG(("DATA",tree)); return tree; /* Builtins */ case Node_builtin: DEBUG(("builtin",tree)); return ((*tree->proc)(tree->subnode)); /* unary operations */ case Node_var: case Node_subscript: case Node_field_spec: DEBUG(("var_type ref",tree)); lhs=get_lhs(tree); return *lhs; case Node_preincrement: case Node_predecrement: DEBUG(("+-X",tree)); lhs=get_lhs(tree->subnode); assign_number(lhs,force_number(*lhs) + (tree->type==Node_preincrement ? 1.0 : -1.0)); return *lhs; case Node_postincrement: case Node_postdecrement: DEBUG(("X+-",tree)); lhs=get_lhs(tree->subnode); x = force_number(*lhs); assign_number (lhs, x + (tree->type==Node_postincrement ? 1.0 : -1.0)); return tmp_number(x); case Node_unary_minus: DEBUG(("UMINUS",tree)); return tmp_number(-force_number(tree_eval(tree->subnode))); /* assignments */ case Node_assign: DEBUG(("ASSIGN",tree)); r = tree_eval (tree->rnode); lhs=get_lhs(tree->lnode); *lhs= dupnode(r); do_deref(); /* FOO we have to regenerate $0 here! */ if(tree->lnode->type==Node_field_spec) fix_fields(); return r; /* other assignment types are easier because they are numeric */ case Node_assign_times: r = tree_eval (tree->rnode); lhs=get_lhs(tree->lnode); assign_number(lhs, force_number(*lhs) * force_number(r)); do_deref(); return *lhs; case Node_assign_quotient: r = tree_eval (tree->rnode); lhs=get_lhs(tree->lnode); assign_number(lhs, force_number(*lhs) / force_number(r)); do_deref(); return *lhs; case Node_assign_mod: r = tree_eval (tree->rnode); lhs=get_lhs(tree->lnode); assign_number(lhs, (AWKNUM)(((int) force_number(*lhs)) % ((int) force_number(r)))); do_deref(); return *lhs; case Node_assign_plus: r = tree_eval (tree->rnode); lhs=get_lhs(tree->lnode); assign_number(lhs, force_number(*lhs) + force_number(r)); do_deref(); return *lhs; case Node_assign_minus: r = tree_eval (tree->rnode); lhs=get_lhs(tree->lnode); assign_number(lhs, force_number(*lhs) - force_number(r)); do_deref(); return *lhs; } /* Note that if TREE is invalid, gAWK will probably bomb in one of these tree_evals here. */ /* evaluate subtrees in order to do binary operation, then keep going */ t1 = tree_eval (tree->lnode); t2 = tree_eval (tree->rnode); switch (tree->type) { case Node_concat: t1=force_string(t1); t2=force_string(t2); r=(NODE *)obstack_alloc(&temp_strings,sizeof(NODE)); r->type=Node_temp_string; r->stlen=t1->stlen+t2->stlen; r->stref=1; r->stptr=(char *)obstack_alloc(&temp_strings,r->stlen+1); bcopy(t1->stptr,r->stptr,t1->stlen); bcopy(t2->stptr,r->stptr+t1->stlen,t2->stlen); r->stptr[r->stlen]='\0'; return r; case Node_times: return tmp_number(force_number(t1) * force_number(t2)); case Node_quotient: x=force_number(t2); if(x==(AWKNUM)0) return tmp_number((AWKNUM)0); else return tmp_number(force_number(t1) / x); case Node_mod: x=force_number(t2); if(x==(AWKNUM)0) return tmp_number((AWKNUM)0); return tmp_number((AWKNUM) /* uggh... */ (((int) force_number(t1)) % ((int) x))); case Node_plus: return tmp_number(force_number(t1) + force_number(t2)); case Node_minus: return tmp_number(force_number(t1) - force_number(t2));#ifndef FAST default: fprintf (stderr, "internal error: illegal numeric operation\n"); abort ();#endif } return 0;}/* We can't dereference a variable until after we've given it its new value. This variable points to the value we have to free up */NODE *deref;/* This returns a POINTER to a node pointer. *get_lhs(ptr) is the current value of the var, or where to store the var's new value */NODE **get_lhs(ptr)NODE *ptr;{ register1 NODE *subexp; register1 NODE **aptr; register1 int num; extern NODE **fields_arr; extern f_arr_siz; NODE **assoc_lookup(); extern char f_empty[]; /* jfw */#ifndef FAST if(ptr == NULL) abort();#endif deref = NULL; switch(ptr->type) { case Node_var: deref=ptr->var_value; return &(ptr->var_value); case Node_field_spec: num=(int)force_number(tree_eval(ptr->lnode)); if(num<0) num=0; /* JF what should I do? */ if(num>f_arr_siz) set_field(num,f_empty,0); /* jfw: so blank_strings can be simpler */ deref = NULL; return &fields_arr[num]; case Node_subscript: subexp = tree_eval(ptr->rnode); aptr=assoc_lookup(ptr->lnode,subexp); deref= *aptr; return aptr; }#ifndef FAST abort(); return 0;#endif}do_deref(){ if(deref) { switch(deref->type) { case Node_string: if(deref!=Nnull_string) FREE_ONE_REFERENCE(deref); break; case Node_number: free((char *)deref); break;#ifndef FAST default: abort();#endif } deref = 0; }}/* This makes numeric operations slightly more efficient. Just change the value of a numeric node, if possible */assign_number (ptr, value)NODE **ptr;AWKNUM value;{ switch ((*ptr)->type) { case Node_string: if(*ptr!=Nnull_string) FREE_ONE_REFERENCE (*ptr); case Node_temp_string: /* jfw: dont crash if we say $2 += 4 */ *ptr=make_number(value); return; case Node_number: (*ptr)->numbr = value; deref=0; break;#ifndef FAST default: printf("assign_number nodetype %d\n", (*ptr)->type); /* jfw: add mesg. */ abort ();#endif }}/* Routines to deal with fields */#define ORIG_F 30NODE **fields_arr;NODE *fields_nodes;int f_arr_siz;char f_empty [] = "";init_fields(){ register1 NODE **tmp; register1 NODE *xtmp; f_arr_siz=ORIG_F; fields_arr=(NODE **)malloc(ORIG_F * sizeof(NODE *)); fields_nodes=(NODE *)malloc(ORIG_F * sizeof(NODE)); tmp= &fields_arr[f_arr_siz]; xtmp= &fields_nodes[f_arr_siz]; while(--tmp>= &fields_arr[0]) { --xtmp; *tmp=xtmp; xtmp->type=Node_temp_string; xtmp->stlen=0; xtmp->stref=1; xtmp->stptr=f_empty; }}blank_fields(){ register1 NODE **tmp; extern char *parse_end; tmp= &fields_arr[f_arr_siz]; while(--tmp>= &fields_arr[0]) { switch(tmp[0]->type) { case Node_number: free((char *)*tmp); *tmp= &fields_nodes[tmp-fields_arr]; break; case Node_string: if(*tmp!=Nnull_string) FREE_ONE_REFERENCE(*tmp); *tmp= &fields_nodes[tmp-fields_arr]; break; case Node_temp_string: break;#ifndef FAST default: abort();#endif } if ((*tmp)->stptr != f_empty) { /* jfw */ /*Then it was assigned a string with set_field */ /*out of a private buffer to inrec, so don't free it*/ (*tmp)->stptr = f_empty; (*tmp)->stlen = 0; (*tmp)->stref = 1; } /* *tmp=Nnull_string; */ } /* Free the strings */ obstack_free(&other_stack,parse_end);}/* Danger! Must only be called for f
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:gawk ƒ:awk2.c
+++++ Continued from previous card +++++
ields we know have just been blanked, or fields we know don't exist yet. */set_field(n,str,len)char *str;{ NODE *field_string(); if(n>f_arr_siz) { int t; fields_arr=(NODE **)realloc((char *)fields_arr,(n+1)*sizeof(NODE *)); fields_nodes=(NODE *)realloc((char *)fields_nodes,(n+1)*sizeof(NODE)); for(t=f_arr_siz;t<=n;t++) { fields_arr[t]= &fields_nodes[t]; fields_nodes[t].type=Node_temp_string; fields_nodes[t].stlen=0; fields_nodes[t].stref=1; fields_nodes[t].stptr=f_empty; } f_arr_siz=n+1; } fields_nodes[n].stlen=len; if(n==0) { fields_nodes[n].stptr=(char*)obstack_alloc(&other_stack,len+1); bcopy(str,fields_nodes[n].stptr,len); fields_nodes[n].stptr[len]='\0'; } else { fields_nodes[n].stptr=str; str[len]='\0'; }}#ifdef DONTDEF/* Nodes created with this will go away when the next input line is read */NODE *field_string(s,len)char *s;{ register1 NODE *r; r=(NODE *)obstack_alloc(&other_stack,sizeof(NODE)); r->type=Node_temp_string; r->stref=1; r->stlen=len; r->stptr=(char*)obstack_alloc(&other_stack,len+1); bcopy(s,r->stptr,len); /* r->stptr=s; r->stptr[len]='\0'; */ return r;}#endif/* Someone assigned a value to $(something). Fix up $0 to be right */fix_fields(){ register1 int tlen; register1 NODE *tmp; NODE *ofs; char *ops; register1 char *cops; register1 NODE **ptr,**maxp; extern NODE *OFS_node; maxp=0; tlen=0; ofs=force_string(*get_lhs(OFS_node)); ptr= &fields_arr[f_arr_siz]; while(--ptr> &fields_arr[0]) { tmp=force_string(*ptr); tlen+=tmp->stlen; if(tmp->stlen && !maxp) maxp=ptr; } if(!maxp) { if (fields_arr[0] != fields_nodes) FREE_ONE_REFERENCE(fields_arr[0]); fields_arr[0]=Nnull_string; return; } tlen+=((maxp-fields_arr)-1)*ofs->stlen; ops=(char *)malloc(tlen+1); cops=ops; for(ptr= &fields_arr[1];ptr<=maxp;ptr++) { tmp=force_string(*ptr); bcopy(tmp->stptr,cops,tmp->stlen); cops+=tmp->stlen; if(ptr!=maxp) { bcopy(ofs->stptr,cops,ofs->stlen); cops+=ofs->stlen; } } tmp=newnode(Node_string); tmp->stptr=ops; tmp->stlen=tlen; tmp->stref=1; tmp->stptr[tlen]='\0'; /* don't free unless it's new */ if (fields_arr[0] != fields_nodes) FREE_ONE_REFERENCE(fields_arr[0]); fields_arr[0]=tmp;}/* Is TREE true or false? Returns 0==false, non-zero==true */inteval_condition (tree)NODE *tree;{ register1 int di; register1 NODE *t1,*t2; if(tree==NULL) /* Null trees are the easiest kinds */ return 1; switch (tree->type) { /* Maybe it's easy; check and see. */ /* BEGIN and END are always false */ case Node_K_BEGIN: return 0; break; case Node_K_END: return 0; break; case Node_and: return eval_condition (tree->lnode) && eval_condition (tree->rnode); case Node_or: return eval_condition (tree->lnode) || eval_condition (tree->rnode); case Node_not: return !eval_condition (tree->lnode); /* Node_line_range is kind of like Node_match, EXCEPT: * the lnode field (more properly, the condpair field) is a node of * a Node_cond_pair; whether we evaluate the lnode of that node or the * rnode depends on the triggered word. More precisely: if we are not * yet triggered, we tree_eval the lnode; if that returns true, we set * the triggered word. If we are triggered (not ELSE IF, note), we * tree_eval the rnode, clear triggered if it succeeds, and perform our * action (regardless of success or failure). We want to be able to * begin and end on a single input record, so this isn't an ELSE IF, as * noted above. * This feature was implemented by John Woods, jfw@eddie.mit.edu, during * a rainy weekend. */ case Node_line_range: if (!tree->triggered) if (!eval_condition(tree->condpair->lnode)) return 0; else tree->triggered = 1; /* Else we are triggered */ if (eval_condition(tree->condpair->rnode)) tree->triggered = 0; return 1; } /* Could just be J.random expression. in which case, null and 0 are false, anything else is true */ switch(tree->type) { case Node_match: case Node_nomatch: case Node_equal: case Node_notequal: case Node_less: case Node_greater: case Node_leq: case Node_geq: break; default: /* This is so 'if(iggy)', etc, will work */ /* Non-zero and non-empty are true */ t1=tree_eval(tree); switch(t1->type) { case Node_number: return t1->numbr!=0.0; case Node_string: case Node_temp_string: return t1->stlen!=0;#ifndef FAST default: abort();#endif } } /* couldn't fob it off recursively, eval left subtree and see if it's a pattern match operation */ t1 = tree_eval (tree->lnode); if (tree->type == Node_match || tree->type == Node_nomatch) { t1=force_string(t1); return (re_search (tree->rereg, t1->stptr, t1->stlen, 0, t1->stlen, NULL) == -1) ^ (tree->type == Node_match); } /* still no luck--- eval the right subtree and try binary ops */ t2 = tree_eval (tree->rnode); di=cmp_nodes(t1,t2); switch (tree->type) { case Node_equal: return di == 0; case Node_notequal: return di != 0; case Node_less: return di < 0; case Node_greater: return di > 0; case Node_leq: return di <= 0; case Node_geq: return di >= 0;#ifndef FAST default: fprintf(stderr,"Panic: unknown conditonal\n"); abort ();#endif } return 0;}/* FOO this doesn't properly compare "12.0" and 12.0 etc *//* or "1E1" and 10 etc *//* Perhaps someone should fix it. *//* Consider it fixed (jfw) *//* strtod() would have been better, except (1) real awk is needlessly * restrictive in what strings it will consider to be numbers, and * (2) I couldn't find the public domain version anywhere handy. */is_a_number(str) /* does the string str have pure-numeric syntax? */char *str; /* don't convert it, assume that atof is better */{ if (*str == 0) return 1; /* null string has numeric value of0 */ /* This is still a bug: in real awk, an explicit "" string * is not treated as a number. Perhaps it is only variables * that, when empty, are also 0s. This bug-lette here at * least lets uninitialized variables to compare equal to * zero like they should. */ if (*str == '-') str++; if (*str == 0) return 0; /* must be either . or digits (.4 is legal) */ if (*str != '.' && !isdigit(*str)) return 0; while (isdigit(*str)) str++; if (*str == '.') { str++; while (isdigit(*str)) str++; } /* curiously, real awk DOESN'T consider "1E1" to be equal to 10! * Or even equal to 1E1 for that matter! For a laugh, try: * awk 'BEGIN {if ("1E1" == 1E1) print "eq"; else print "neq";exit}' * Since this behavior is QUITE curious, I include the code for the * adventurous. One might also feel like skipping leading whitespace * (awk doesn't) and allowing a leading + (awk doesn't).#ifdef Allow_Exponents if (*str == 'e' || *str == 'E') { str++; if (*str == '+' || *str == '-') str++; if (!isdigit(*str)) return 0; while (isdigit(*str)) str++; }#endif /* if we have digested the whole string, we are successful */ return (*str == 0);}cmp_nodes(t1,t2)NODE *t1,*t2;{ register1 int di; register1 AWKNUM d; if(t1==t2) { return 0; }#ifndef FAST if(!t1 || !t2) { abort(); return t1 ? 1 : -1; }#endif if (t1->type == Node_number && t2->type == Node_number) { d = t1->numbr - t2->numbr; if (d < 0.0) return -1; if (d > 0.0) return 1; return 0; } t1=force_string(t1); t2=force_string(t2); /* "real" awk treats things as numbers if they both "look" like numbers. */ if (*t1->stptr && *t2->stptr /* don't allow both to be empty strings(jfw)*/ && is_a_number(t1->stptr) && is_a_number(t2->stptr)) { double atof(); d = atof(t1->stptr) - atof(t2->stptr); if (d < 0.0) return -1; if (d > 0.0) return 1; return 0; } di = strncmp (t1->stptr, t2->stptr, min (t1->stlen, t2->stlen)); if (di == 0) di = t1->stlen - t2->stlen; if(di>0) return 1; if(di<0) return -1; return 0;}#ifdef DONTDEFint primes[] = {31,61,127,257,509,1021,2053,4099,8191,16381};#endif/* routines for associative arrays. SYMBOL is the address of the node (or other pointer) being dereferenced. SUBS is a number or string used as the subscript. *//* #define ASSOC_HASHSIZE 1009 /* prime */#define ASSOC_HASHSIZE 29#define STIR_BITS(n) ((n) << 5 | (((n) >> 27) & 0x1f))#define HASHSTEP(old, c) ((old << 1) + c)#define MAKE_POS(v) (v & ~0x80000000) /* make number positive *//* static AHASH *assoc_table[ASSOC_HASHSIZE]; *//* Flush all the values in symbol[] before doing a split() */assoc_clear(symbol)NODE *symbol;{ int i; AHASH *bucket,*next; if(symbol->var_array==0) return; for(i=0;i<ASSOC_HASHSIZE;i++) { for(bucket=symbol->var_array[i];bucket;bucket=next) { next=bucket->next; deref=bucket->name; do_deref(); deref=bucket->value; do_deref(); free((void *)bucket); } symbol->var_array[i]=0; }}/* Find SYMBOL[SUBS] in the assoc array. Install it with value "" if it isn't there. *//* Returns a pointer ala get_lhs to where its value is stored */NODE **assoc_lookup (symbol, subs)NODE *symbol, *subs;{ int hash1 = 0, hashf(), i; AHASH *bucket; NODETYPE ty; if(subs->type==Node_number) { hash1=(int)subs->numbr; ty=Node_number; } else { ty=Node_string; subs=force_string(subs); for(i=0;i<subs->stlen;i++) hash1=HASHSTEP(hash1,subs->stptr[i]); /* hash1 ^= (int) STIR_BITS((int)symbol); */ } hash1 = MAKE_POS(STIR_BITS((int)hash1)) % ASSOC_HASHSIZE; /* this table really should grow dynamically */ if(symbol->var_array==0) { symbol->var_array=(AHASH **)malloc(sizeof(AHASH *)*ASSOC_HASHSIZE); for(i=0;i<ASSOC_HASHSIZE;i++) { symbol->var_array[i]=0; } } else { for (bucket = symbol->var_array[hash1]; bucket; bucket = bucket->next) { if (bucket->name->type!= ty || cmp_nodes(bucket->name,subs)) continue; return &(bucket->value); } /* Didn't find it on first pass. Try again. */ for (bucket = symbol->var_array[hash1]; bucket; bucket = bucket->next) { if (cmp_nodes(bucket->name,subs)) continue; return &(bucket->value); } } bucket = (AHASH *) malloc(sizeof (AHASH)); bucket->symbol = symbol; bucket->name = dupnode(subs); bucket->value = Nnull_string; bucket->next = symbol->var_array[hash1]; symbol->var_array[hash1]=bucket; return &(bucket->value);}struct search *assoc_scan(symbol)NODE *symbol;{ struct search *lookat; if(!symbol->var_array) return 0; lookat=(struct search *)obstack_alloc(&other_stack,sizeof(struct search)); /* lookat->symbol=symbol; */ lookat->numleft=ASSOC_HASHSIZE; lookat->arr_ptr=symbol->var_array; lookat->bucket=symbol->var_array[0]; return assoc_next(lookat);}struct search *assoc_next(lookat)struct search *lookat;{ for(;lookat->numleft;lookat->numleft--) { while(lookat->bucket!=0) { lookat->retval=lookat->bucket->name; lookat->bucket=lookat->bucket->next; return lookat; } lookat->bucket= *++(lookat->arr_ptr); } return 0;}#ifdef FASTNODE *strforce(n)NODE *n;{ extern NODE dumb[],*OFMT_node; NODE *do_sprintf(); dumb[1].lnode=n; if(OFMT_node->var_value->type!=Node_string) panic("Insane value for OFMT detected."); return do_sprintf(&dumb[0]);}#elseAWKNUMforce_number (n)NODE *n;{ double atof(); /* Forgetting this is bad */ if(n==NULL) abort(); switch (n->type) { case Node_number: return n->numbr; case Node_string: case Node_temp_string: return atof(n->stptr); default: abort (); } return 0.0;}NODE *force_string(s)NODE *s;{ if(s==NULL) abort(); switch(s->type) { case Node_string: case Node_temp_string: return s; case Node_number: if((*get_lhs(OFMT_node))->type!=Node_string) panic("Insane value for OFMT!",0); dumb[1].lnode=s; return do_sprintf(&dumb[0]); default: abort(); } return NULL;}#endif :MPW:MPW Tools:Tools with Source:gawk ƒ:awk3.c
#define register1 /* awk3.c -- Builtin functions and various utility procedures Copyright (C) 1986,1987 Free Software Foundation Written by Jay Fenlason, December 1986 *//*GAWK is distributed in the hope that it will be useful, but WITHOUT ANYWARRANTY. No author or distributor accepts responsibility to anyonefor the consequences of using it or for whether it serves anyparticular purpose or works at all, unless he says so in writing.Refer to the GAWK General Public License for full details.Everyone is granted permission to copy, modify and redistribute GAWK,but only under the conditions described in the GAWK General PublicLicense. A copy of this license is supposed to have been given to youalong with GAWK so you can know your rights and responsibilities. Itshould be in a file named COPYING. Among other things, the copyrightnotice and this notice must be preserved on all copies.In other words, go ahead and share GAWK, but don't try to stopanyone else from sharing it farther. Help stamp out software hoarding!*/#include <stdio.h>#include <string.h>#include <math.h>#include "awk.h"#include "obstack.h"extern struct obstack temp_strings;void dbprint();/* This node is the cannonical null string, used everywhere */extern NODE *Nnull_string;/* These nodes store all the special variables gAWK uses */NODE *FS_node, *NF_node, *RS_node, *NR_node;NODE *FILENAME_node, *OFS_node, *ORS_node, *OFMT_node;/* This dumb kludge is used by force_string to turn a floating point number into a string */NODE dumb[2];NODE **get_lhs();FILE *deal_redirect();void *alloca();struct redirect { int flag; /* JF was NODETYPE */ NODE *value; FILE *fp;};struct redirect reds[20]; /* An arbitrary limit, surely, but there's an arbitrary limit on open files, too. So it doesn't make much difference, does it? */long NR;int NF;/* The next #define tells how you find $0. Its a hack */extern NODE **fields_arr;#define WHOLELINE fields_arr[0]/* Set all the special variables to their initial values. Also sets up the dumb[] array for force_string */init_vars(){ NODE *spc_var(); NODE *do_sprintf(); FS_node=spc_var("FS",make_string(" ",1)); NF_node=spc_var("NF",make_number(0.0)); RS_node=spc_var("RS",make_string("\r",1)); NR_node=spc_var("NR",make_number(0.0)); FILENAME_node=spc_var("FILENAME",make_string("-",1)); /* Was Nnull_string */ OFS_node=spc_var("OFS",make_string(" ",1)); ORS_node=spc_var("ORS",make_string("\r",1)); OFMT_node=spc_var("OFMT",make_string("%.6g",4)); /* This ugly hack is used by force_string to fake a call to sprintf */ dumb[0].type=Node_expression_list; dumb[0].lnode=OFMT_node; dumb[0].rnode= &dumb[1]; dumb[1].type=Node_expression_list; dumb[1].lnode=(NODE *)0; /* fill in the var here */ dumb[1].rnode=(NODE *)0; reds[0].flag=0; /* Don't depend on uninit data being zero, although it should be */}/* OFMT is special because we don't dare use force_string on it for fear of infinite loops. Thus, if it isn't a string, we return the default "%.6g" This may or may not be the right thing to do, but its the easiest *//* This routine isn't used! It should be. */char *get_ofmt(){ register1 NODE *tmp; tmp= *get_lhs(OFMT_node); if(tmp->type!=Node_string || tmp->stlen==0) return "%.6g"; return tmp->stptr;}intget_fs(){ register1 NODE *tmp; tmp=force_string(FS_node->var_value); if(tmp->stlen==0) return 0; return *(tmp->stptr);}set_fs(str)char *str;{ register1 NODE **tmp; tmp= get_lhs(FS_node); do_deref(); /* stupid special case so -F\t works as documented in awk */ /* even though the shell hands us -Ft. Bleah! (jfw) */ if (*str == 't') *str == '\t'; *tmp=make_string(str,1);}set_rs(str)char *str;{ register1 NODE **tmp; tmp= get_lhs(RS_node); do_deref(); /* stupid special case to be consistent with -F (jfw) */ if (*str == 't') *str == '\t'; *tmp=make_string(str,1);}intget_rs(){ register1 NODE *tmp; tmp=force_string(RS_node->var_value); if(tmp->stlen==0) return 0; return *(tmp->stptr);}/* Builtin functions */NODE *do_exp(tree)NODE *tree;{ NODE *tmp; double exp(); get_one(tree,&tmp); return tmp_number(exp(force_number(tmp)));}/* JF: I don't know what this should return. *//* jfw: 1 if successful or by land, 0 if end of file or by sea */NODE *do_getline(tree)NODE *tree;{ if(inrec() == 0) return tmp_number(1.0); else return tmp_number(0.0);}NODE *do_index(tree)NODE *tree;{ NODE *s1,*s2; register1 char *p1,*p2; register1 int l1,l2; get_two(tree,&s1,&s2); p1=s1->stptr; p2=s2->stptr; l1=s1->stlen; l2=s2->stlen; while(l1) { if(!strncmp(p1,p2,l2)) return tmp_number((AWKNUM)(1+s1->stlen-l1)); l1--; p1++; } return tmp_number(0.0);}NODE *do_int(tree)NODE *tree;{ NODE *tmp; double floor(); get_one(tree,&tmp); return tmp_number(floor(force_number(tmp)));}NODE *do_length(tree)NODE *tree;{ NODE *tmp; get_one(tree,&tmp); return tmp_number((AWKNUM)(force_string(tmp)->stlen));}NODE *do_log(tree)NODE *tree;{ NODE *tmp; double log(); get_one(tree,&tmp); return tmp_number(log(force_number(tmp)));}NODE *do_printf(tree)NODE *tree;{ register1 FILE *fp; NODE *do_sprintf(); fp=deal_redirect(tree->rnode); print_simple(do_sprintf(tree->lnode),fp); return Nnull_string;}NODE *do_split(tree)NODE *tree;{ NODE *t1,*t2,*t3; register1 int splitc; register1 int num,snum,olds; register1 char *ptr,*oldp; NODE **assoc_lookup(); if(a_get_three(tree,&t1,&t2,&t3)<3) splitc= get_fs(); else splitc= *(force_string(t3)->stptr); num=0; tree=force_string(t1); olds=snum=tree->stlen; oldp=ptr=tree->stptr; assoc_clear(t2); if(splitc==' ') { while(*ptr==' ' || *ptr=='\t') { --snum; ptr++; } oldp=ptr; olds=snum; } while(snum--) { if((splitc==' ' && (*ptr==' ' || *ptr=='\t')) || *ptr==splitc) { ptr++; *assoc_lookup(t2,make_number((AWKNUM)(++num)))=make_string(oldp,(olds-snum)-1); if(splitc==' ') while(*ptr==' ' || *ptr=='\t') { ptr++; --snum; } oldp=ptr; olds=snum; } else ptr++; } *assoc_lookup(t2,make_number((AWKNUM)(++num)))=make_string(oldp,(olds-snum)-1); return tmp_number((AWKNUM)num);}/* Note that the output buffer cannot be static because sprintf may get called recursively by force_string. Hence the wasteful alloca calls *//* %e and %f formats are not properly implemented. Someone should fix them */NODE *do_sprintf(tree)NODE *tree;{#define bchunk(s,l) if(l) {\ if((l)>ofre) {\ char *tmp;\ tmp=(char *)alloca((long) osiz*2);\ bcopy(obuf,tmp,olen);\ obuf=tmp;\ ofre+=osiz;\ osiz*=2;\ }\ bcopy(s,obuf+olen,(l));\ olen+=(l);\ ofre-=(l);\ }/* Is there space for something L big in the buffer? */#define chksize(l) if((l)>ofre) {\ char *tmp;\ tmp=(char *)alloca((long) osiz*2);\ bcopy(obuf,tmp,olen);\ obuf=tmp;\ ofre+=osiz;\ osiz*=2;\ }/* Get the next arg to be formatted. If we've run out of args, return "" (Null string) */#define parse_next_arg() {\ if(!carg) arg= Nnull_string;\ else {\ get_one(carg,&arg);\ carg=carg->rnode;\ }\ } char *obuf; int osiz,ofre,olen; static char chbuf[] = "0123456789abcdef"; static char sp[] =" "; char *s0,*s1; int n0; NODE *sfmt,*arg; register1 NODE *carg; long fw,prec,lj,alt,big; long *cur; long val; unsigned long uval; int sgn; int base; char cpbuf[30]; /* if we have numbers bigger than 30 */ char *cend= &cpbuf[30]; /* chars, we lose, but seems unlikely */ char *cp; char *fill; double tmpval; char *pr_str; obuf=(char *)alloca((long) 120); osiz=120; ofre=osiz; olen=0; get_one(tree,&sfmt); sfmt=force_string(sfmt); carg=tree->rnode; for(s0=s1=sfmt->stptr,n0=sfmt->stlen;n0-->0;) { if(*s1!='%') { s1++; continue; } bchunk(s0,s1-s0); s0=s1; cur= &fw; fw=0; prec=0; lj=alt=big=0; fill= sp; cp=cend; s1++; retry: --n0; switch(*s1++) { case '%': bchunk("%",1); s0=s1; break; case '0': if(fill!=sp || lj) goto lose; fill="0"; /* FALL through */ case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': if(cur==0) g; *cur= s1[-1]-'0'; while(n0>0 && *s1>='0' && *s1<='9') { --n0; *cur= *cur * 10 + *s1++ - '0'; } goto retry; case '-': if(lj || fill!=sp) goto lose; lj++; goto retry; case '.': if(cur!=&fw) goto lose; cur= ≺ goto retry; case '#': if(alt) goto lose; alt++; goto retry; case 'l': if(big) goto lose; big++; goto retry; case '*': if(cur==0) goto lose; parse_next_arg(); *cur=(long)arg; goto retry; case 'c': parse_next_arg(); if(arg->type==Node_number) { uval=(unsigned long)arg->numbr; cpbuf[0]=uval; prec=1; pr_str=cpbuf; goto dopr_string; } if(!prec || prec>arg->stlen) prec=arg->stlen; pr_str=cpbuf; goto dopr_string; case 's': parse_next_arg(); arg=force_string(arg); if(!prec || prec>arg->stlen) prec=arg->stlen; pr_str=arg->stptr; dopr_string: if(fw>prec && !lj) { while(fw>prec) { bchunk(sp,1); fw--; } } bchunk(pr_str,(long)prec); if(fw>prec) { while(fw>prec) { bchunk(sp,1); fw--; } } s0=s1; break; case 'd': parse_next_arg(); val=(long)force_number(arg); if(val<0) { sgn=1; val= -val; } else sgn=0; do { *--cp='0'+val%10; val/=10; } while (val); if(sgn) *--cp='-'; prec=cend-cp; if(fw>prec && !lj) { if(fill!=sp && *cp=='-') { bchunk(cp,1); cp++; prec--; fw--; } while(fw>prec) { bchunk(fill,1); fw--; } } bchunk(cp,(int)prec); if(fw>prec) { while(fw>prec) { bchunk(fill,1); fw--; } } s0=s1; break; case 'u': base=10; goto pr_unsigned; case 'o': base=8; goto pr_unsigned; case 'x': base=16; goto pr_unsigned; pr_unsigned: parse_next_arg(); uval=(unsigned long)force_number(arg); do { *--cp=chbuf[uval%base]; uval/=base; } while(uval); prec=cend-cp; if(fw>prec && !lj) { while(fw>prec) { bchunk(fill,1); fw--; } } bchunk(cp,(int)prec); if(fw>prec) { while(fw>prec) { bchunk(fill,1); fw--; } } s0=s1; break; case 'g': parse_next_arg(); tmpval=force_number(arg); if(prec==0) prec=13; else { long foo = abs((long)tmpval); if(prec<9 && foo>99999999) prec=9; else if(prec<8 && foo>9999999) prec=8; else if(prec<7 && foo>999999) prec=7; else if(prec<6 && foo>99999) prec=6; else if(prec<5 && foo>9999) prec=5; else if(prec<4 && foo>999) prec=4; else if(prec<3 && foo>99) prec=3; else if(prec<2 && foo>9) prec=2; } gcvt(tmpval,prec,cpbuf); prec=strlen(cpbuf); cp=cpbuf; if(fw>prec && !lj) { if(fill!=sp && *cp=='-') { bchunk(cp,1); cp++; prec--; } /* Deal with .5 as 0.5 */ if(fill==sp && *cp=='.') { --fw; while(--fw>=prec) { bchunk(fill,1); } bchunk("0",1); } else while(fw-->prec) bchunk(fill,1); } else { /* Turn .5 into 0.5 */ /* FOO */ if(*cp=='.' && fill==sp) { bchunk("0",1); --fw; } } bchunk(cp,(int)prec); if(fw>prec) while(fw-->prec) bchunk(fill,1); s0=s1; break; /* JF how to handle these!? */ case 'f': parse_next_arg(); tmpval=force_number(arg); chksize(fw+prec+5); /* 5==slop *//* cp=fcvt(tmpval,prec,&dec,&sgn); prec=strlen(cp); if(sgn) prec++; */ cp=cpbuf; *cp++='%'; if(lj) *cp++='-'; if(fill!=sp) *cp++='0'; if(prec!=0) { strcpy(cp,"*.*f"); sprintf(obuf+olen,cpbuf,fw,prec,(double)tmpval); } else { strcpy(cp,"*f"); sprintf(obuf+olen,cpbuf,fw,(double)tmpval); } cp=obuf+olen; ofre-=strlen(obuf+olen); olen+=strlen(obuf+olen);/* There may be nulls */ s0=s1; break; case 'e': parse_next_arg(); tmpval=force_number(arg); chksize(fw+prec+5); /* 5==slop */ cp=cpbuf; *cp++='%'; if(lj) *cp++='-'; if(fill!=sp) *cp++='0'; if(prec!=0) { strcpy(cp,"*.*e"); sprintf(obuf+olen,cpbuf,fw,prec,(double)tmpval); } else { strcpy(cp,"*e"); sprintf(obuf+olen,cpbuf,fw,(double)tmpval); } cp=obuf+olen; ofre-=strlen(obuf+olen); olen+=strlen(obuf+olen);/* There may be nulls */ s0=s1; break; break; /* case 'g': parse_next_arg(); tmpval=force_number(arg); if(prec!=0) sprintf(obuf+osiz-ofre,"%*.*g",fw,prec,(double)tmpval); else sprintf(obuf+osiz-ofre,"%*g",fw,(double)tmpval); ofre-=strlen(obuf+osiz-ofre); s0=s1; break; */ default: lose: break; } } bchunk(s0,s1-s0); return tmp_string(obuf,olen);}NODE *do_sqrt(tree)NODE *tree;{ NODE *tmp; double sqrt(); get_one(tree,&tmp); return tmp_number(sqrt(force_number(tmp)));}NODE *do_substr(tree)NODE *tree;{ NODE *t1,*t2,*t3; register1 int n1,n2; if(get_three(tree,&t1,&t2,&t3)<3) n2=32000; else n2=(int)force_number(t3); n1=(int)force_number(t2)-1; tree=force_string(t1); if(n1<0 || n1>=tree->stlen || n2<=0) return Nnull_string; if(n1+n2>tree->stlen) n2=tree->stlen-n1; return tmp_string(tree->stptr+n1,n2);}/* The print command. Its name is historical */hack_print_node(tree)NODE *tree;{ register1 FILE *fp;#ifndef FAST if(!tree || tree->type != Node_K_print) abort();#endif fp=deal_redirect(tree->rnode); tree=tree->lnode; if(!tree) tree=WHOLELINE; if(tree->type!=Node_expression_list) { print_simple(tree,fp); } else { while(tree) { print_simple(tree_eval(tree->lnode),fp); tree=tree->rnode; if(tree) print_simple(OFS_node->var_value,fp); } } print_simple(ORS_node->var_value,fp);}/* Get the arguments to functions. No function cares if you give it too many args (they're ignored). Only a few fuctions complain about being given too few args. The rest have defaults */get_one(tree,res)NODE *tree,**res;{ if(!tree) { *res= WHOLELINE; return; }#ifndef FAST if(tree->type!=Node_expression_list) abort();#endif *res=tree_eval(tree->lnode);}get_two(tree,res1,res2)NODE *tree,**res1,**res2;{ if(!tree) { *res1= WHOLELINE; return; }#ifndef FAST if(tree->type!=Node_expression_list) abort();#endif *res1=tree_eval(tree->lnode); if(!tree->rnode) return; tree=tree->rnode;#ifndef FAST if(tree->type!=Node_expression_list) abort();#endif *res2=tree_eval(tree->lnode);}get_three(tree,res1,res2,res3)NODE *tree,**res1,**res2,**res3;{ if(!tree) { *res1= WHOLELINE; return 0; }#ifndef FAST if(tree->type!=Node_expression_list) abort();#endif *res1=tree_eval(tree->lnode); if(!tree->rnode) return 1; tree=tree->rnode;#ifndef FAST if(tree->type!=Node_expression_list) abort();#endif *res2=tree_eval(tree->lnode); if(!tree->rnode) return 2; tree=tree->rnode;#ifndef FAST if(tree->type!=Node_expression_list) abort();#endif *res3=tree_eval(tree->lnode); return 3;}a_get_three(tree,res1,res2,res3)NODE *tree,**res1,**res2,**res3;{ if(!tree) { *res1= WHOLELINE; return 0; }#ifndef FAST if(tree->type!=Node_expression_list) abort();#endif *res1=tree_eval(tree->lnode); if(!tree->rnode) return 1; tree=tree->rnode;#ifndef FAST if(tree->type!=Node_expression_list) abort();#endif *res2=tree->lnode; if(!tree->rnode) return 2; tree=tree->rnode;#ifndef FAST if(tree->type!=Node_expression_list) abort();#endif *res3=tree_eval(tree->lnode); return 3;}/* FOO this should re-allocate the buffer if it isn't big enough. Also, it should do RMS style only-parse-enough stuff. *//* This reads in a line from the input file */inrec(){ static char *buf,*buf_end; static bsz; regis
#define register1/* Debug.c -- Various debugging routines Copyright (C) 1986 Free Software Foundation Written by Jay Fenlason, December 1986 *//*GAWK is distributed in the hope that it will be useful, but WITHOUT ANYWARRANTY. No author or distributor accepts responsibility to anyonefor the consequences of using it or for whether it serves anyparticular purpose or works at all, unless he says so in writing.Refer to the GAWK General Public License for full details.Everyone is granted permission to copy, modify and redistribute GAWK,but only under the conditions described in the GAWK General PublicLicense. A copy of this license is supposed to have been given to youalong with GAWK so you can know your rights and responsibilities. Itshould be in a file named COPYING. Among other things, the copyrightnotice and this notice must be preserved on all copies.In other words, go ahead and share GAWK, but don't try to stopanyone else from sharing it farther. Help stamp out software hoarding!*/#include "awk.h"#include <stdio.h>#include <string.h>void dbprint();#ifndef FASTextern NODE **fields_arr;extern f_arr_siz;/* This is all debugging stuff. Ignore it and maybe it'll go away. *//* Some of it could be turned into a really cute trace command, if anyone wants to. */char *nnames[] = { "Illegal Node", "Times", "Divide", "Mod", "Plus", "Minus", "Cond-pair" /* jfw */, "Subscript", "Concat", "++Pre", "--Pre", "Post++", "Post--", "Uminus", "Field", "Assign", "*=", "/=", "%=", "+=", "-=", "And", "Or", "Equal", "!=", "Less", "Greater", "<=", ">=", "Not", "Match", "Nomatch", "String", "TmpString", "Number", "Rule_list", "Rule_node", "State_list", "If_branches", "Exp_list", "BEGIN", "END", "IF", "WHILE", "FOR", "arrayfor", "BREAK", "CONTINUE", "PRINT", "PRINTF", "next", "exit", "redirect", "Append", "Pipe", "variable", "Varray", "builtin", "Line-range" /*jfw*/,};ptree(n){ print_parse_tree((NODE *)n);}pt(){ int x; scanf("%lx",&x); printf("0x%lx\n",x); print_parse_tree((NODE *)x); fflush(stdout);}static depth = 0;print_parse_tree(ptr)NODE *ptr;{ register1 int n; if(!ptr) { printf("NULL\n"); return; } if((int)(ptr->type)<0 || (int)(ptr->type)>sizeof(nnames)/sizeof(nnames[0])) { printf("(0x%lx Type %d??)\n",ptr,ptr->type); return; } printf("(%d)%*s",depth,depth,""); printf("NODETYPE = %d\n",ptr->type); switch((int)ptr->type) { case (int)Node_string: case (int)Node_temp_string: printf("(0x%lx String \"%.*s\")\n",ptr,ptr->stlen,ptr->stptr); return; case (int)Node_number: printf("(0x%lx Number %g)\n",ptr,ptr->numbr); return; case (int)Node_var_array: printf("(0x%lx Array of %d)\n",ptr,ptr->arrsiz); for(n=0;n<ptr->arrsiz;n++) { printf("'"); print_simple((ptr->array)[n*2],stdout); printf("' is '"); print_simple((ptr->array)[n*2+1],stdout); printf("'\n"); } return; } if(ptr->lnode) printf("0x%lx = left<--",ptr->lnode); printf("(0x%lx %s.%d)",ptr,nnames[(int)(ptr->type)],ptr->type); if(ptr->rnode) printf("-->right = 0x%lx",ptr->rnode); printf("\n"); depth++; if(ptr->lnode) print_parse_tree(ptr->lnode); switch((int)ptr->type) { case (int)Node_line_range: /* jfw */ case (int)Node_match: case (int)Node_nomatch: break; case (int)Node_builtin: printf("Builtin: %d\n",ptr->proc); /* jfw: was \N */ break; case (int)Node_K_for: case (int)Node_K_arrayfor: printf("(%s:)\n",nnames[(int)(ptr->type)]); print_parse_tree(ptr->forloop->init); printf("looping:\n"); print_parse_tree(ptr->forloop->cond); printf("doing:\n"); print_parse_tree(ptr->forloop->incr); break; default: if(ptr->rnode) print_parse_tree(ptr->rnode); break; } --depth;}#endif#ifndef FAST/* * print out all the variables in the world */dump_vars(){ register1 int n; register1 HASHNODE *buc; printf("Fields:"); dump_fields(); printf("Vars:\n"); for(n=0;n<HASHSIZE;n++) { for(buc=variables[n];buc;buc=buc->next) { printf("'%.*s': ",buc->length,buc->name); print_simple(buc->value->var_value,stdout); printf(":"); print_parse_tree(buc->value->lnode); /* print_parse_tree(buc->value); */ } } printf("End\n");}#endif#ifndef FASTdump_fields(){ register1 NODE **p; register1 int n; printf("%d fields\n",f_arr_siz); for(n=0,p= &fields_arr[0];n<f_arr_siz;n++,p++) { printf("$%d is '",n); print_simple(*p,stdout); printf("'\n"); }}#endif#ifndef FAST/*VARARGS1*/print_debug(str,n)char *str;NODE *n;{ extern int debugging; if(debugging) printf("%s:0%lx:%d\n",str,n,n->type);} int indent = 0;print_a_node(ptr)NODE *ptr;{ NODE *p1; char *str,*str2; int n; HASHNODE *buc; if(!ptr) return; /* don't print null ptrs */ switch(ptr->type) { case Node_number: printf("%g",ptr->numbr); return; case Node_string: printf("\"%.*s\"",ptr->stlen,ptr->stptr); return; case Node_times: str="*"; goto pr_twoop; case Node_quotient: str="/"; goto pr_twoop; case Node_mod: str="%"; goto pr_twoop; case Node_plus: str="+"; goto pr_twoop; case Node_minus: str="-"; goto pr_twoop; case Node_concat: str=" "; goto pr_twoop; case Node_assign: str="="; goto pr_twoop; case Node_assign_times: str="*="; goto pr_twoop; case Node_assign_quotient: str="/="; goto pr_twoop; case Node_assign_mod: str="%="; goto pr_twoop; case Node_assign_plus: str="+="; goto pr_twoop; case Node_assign_minus: str="-="; goto pr_twoop; case Node_and: str="&&"; goto pr_twoop; case Node_or: str="||"; goto pr_twoop; case Node_equal: str="=="; goto pr_twoop; case Node_notequal: str="!="; goto pr_twoop; case Node_less: str="<"; goto pr_twoop; case Node_greater: str=">"; goto pr_twoop; case Node_leq: str="<="; goto pr_twoop; case Node_geq: str=">="; goto pr_twoop; pr_twoop: print_a_node(ptr->lnode); printf("%s",str); print_a_node(ptr->rnode); return; case Node_not: str="!"; str2=""; goto pr_oneop; case Node_field_spec: str="$("; str2=")"; goto pr_oneop; case Node_postincrement: str=""; str2="++"; goto pr_oneop; case Node_postdecrement: str=""; str2="--"; goto pr_oneop; case Node_preincrement: str="++"; str2=""; goto pr_oneop; case Node_predecrement: str="--"; str2=""; goto pr_oneop; pr_oneop: printf(str); print_a_node(ptr->subnode); printf(str2); return; case Node_expression_list: print_a_node(ptr->lnode); if(ptr->rnode) { printf(","); print_a_node(ptr->rnode); } return; case Node_var: for(n=0;n<HASHSIZE;n++) { for(buc=variables[n];buc;buc=buc->next) { if(buc->value==ptr) { printf("%.*s",buc->length,buc->name); n=HASHSIZE; break; } } } return; case Node_subscript: print_a_node(ptr->lnode); printf("["); print_a_node(ptr->rnode); printf("]"); return; case Node_builtin: printf("some_builtin("); print_a_node(ptr->subnode); printf(")"); return; case Node_statement_list: printf("{\n"); indent++; for(n=indent;n;--n) printf(" "); while(ptr) { print_maybe_semi(ptr->lnode); if(ptr->rnode) for(n=indent;n;--n) printf(" "); ptr=ptr->rnode; } --indent; for(n=indent;n;--n) printf(" "); printf("}\n"); for(n=indent;n;--n) printf(" "); return; case Node_K_if: printf("if("); print_a_node(ptr->lnode); printf(") "); ptr=ptr->rnode; if(ptr->lnode->type==Node_statement_list) { printf("{\n"); indent++; for(p1=ptr->lnode;p1;p1=p1->rnode) { for(n=indent;n;--n) printf(" "); print_maybe_semi(p1->lnode); } --indent; for(n=indent;n;--n) printf(" "); if(ptr->rnode) { printf("} else "); } else { printf("}\n"); return; } } else { print_maybe_semi(ptr->lnode); if(ptr->rnode) { for(n=indent;n;--n) printf(" "); printf("else "); } else return; } if(!ptr->rnode) return; deal_with_curls(ptr->rnode); return; case Node_K_for: printf("for("); print_a_node(ptr->forloop->init); printf(";"); print_a_node(ptr->forloop->cond); printf(";"); print_a_node(ptr->forloop->incr); printf(") "); deal_with_curls(ptr->forsub); return; case Node_K_arrayfor: printf("for("); print_a_node(ptr->forloop->init); printf(" in "); print_a_node(ptr->forloop->incr); printf(") "); deal_with_curls(ptr->forsub); return; case Node_K_printf: printf("printf("); print_a_node(ptr->lnode); printf(")"); return; case Node_K_print: printf("print("); print_a_node(ptr->lnode); printf(")"); return; case Node_K_next: printf("next"); return; case Node_K_break: printf("break"); return; default: print_parse_tree(ptr); return; }}print_maybe_semi(ptr)NODE *ptr;{ print_a_node(ptr); switch(ptr->type) { case Node_K_if: case Node_K_for: case Node_K_arrayfor: case Node_statement_list: break; default: printf(";\n"); break; }}deal_with_curls(ptr)NODE *ptr;{ int n; if(ptr->type==Node_statement_list) { printf("{\n"); indent++; while(ptr) { for(n=indent;n;--n) printf(" "); print_maybe_semi(ptr->lnode); ptr=ptr->rnode; } --indent; for(n=indent;n;--n) printf(" "); printf("}\n"); } else { print_maybe_semi(ptr); }}NODE *do_prvars(){ dump_vars(); return Nnull_string;}NODE *do_bp(){ return Nnull_string;}#endif :MPW:MPW Tools:Tools with Source:gawk ƒ:gnufuncts.c
#include <stdio.h>#include <string.h>#include <math.h>void *memcpy();/*void *alloca(n) /*courtesy Earle Horton*/ long n; { #asm move.l (sp)+,a0 ; pop return address move.l (sp)+,d0 ; pop parameter = size in bytes add.l #3,d0 ; round size up to long word and.l #-4,d0 ; mask out lower two bits of size sub.l d0,sp ; allocate by moving stack pointer move.l sp,d0 ; return pointer add.l #-4,sp ; new top of stack jmp (a0) ; return to caller #endasm }*/ void *bcopy(source,dest,length) void *dest, *source; int length; {void *p; p=memcpy(dest,source,length); return(p);}void perror(s) char *s; {fprintf(stderr,"%s\n",s);}void abort() {exit(20);}void bzero(p,n) void *p; int n; {memset(p,'\0',n);}void gcvt(x,prec,buf) double x; long prec; char *buf; {int i,l; char c; l = prec; sprintf(buf,"%.*lg",l,x); if ((strchr(buf,'E') != 0) || (strchr(buf,'e') !=0 ) ) return; if (strchr(buf,'.') == 0) return; l = strlen(buf); for (i = l - 1;i>0 ;i--) {c = buf[i]; if (c == '.') {buf[i] = '\0'; return;} if (c == '0' ) buf[i] = '\0'; else break;} }FILE *popen(s,mode) char *s,*mode; {fprintf(stderr,"Sorry, pipes are not implemented.\n"); exit(20);}int bcmp(d,d2,mcnt) char *d,*d2; int mcnt; {if (strncmp(d,d2,mcnt)) return(1); else return(0);} :MPW:MPW Tools:Tools with Source:gawk ƒ:Notes_on_gawk
The following changes were made in the gnu sources for gawk to compilethem with Aztec C. (Most of these changes are due to the originalsources assuming that sizeof(integer) = sizeof(pointer)whereas in Aztec C sizeof(integer) = 16 != 32 = sizeof(pointer). )1) in awk.h : #define obstack_chunk_alloc lmalloc replaces #define obstack_chunk_alloc malloc The reason for this is that in AztecC the argument to malloc is short but in obstack.c this is called with a long argument.2) in obstack.h in definition of struct obstack: long temp; /* Temporary for some macros. */ long alignment_mask; /* Mask of alignment for each object. */ Originally these were of type int. The reason for this is that some pointers are stored in temp.3) in regex.c EXTEND_BUFFER: buf.buffer = (char *) malloc ((int) buf.allocated); see note 1.4) in regex.c in EXTEND_BUFFER: long c; In the environment where EXTEND_BUFFER is executed c used to be an int. But c is used in connection with pointer arithmetic.5) in regex.c in EXTEND_BUFFER: bufp->allocated == (1l<<16) In 3 places, this requires 1 to be long.6) in regex.c in re_search:re_search_2 (pbufp, (char *)0, 0, string, size, startpos, range, regs, size) 0 has to be converted to a NULL pointer.7) in regex.c in re_match:re_match_2 (pbufp,(char *)0, 0, string, size, pos, regs, size)ditto.NOTE 1: AztecC seems to handle register variables incorrectly. In particular.the following problems were encountered: In regex.c:re_search2 the loop control register variable range is handled incorrectly during the call to re_match. In awk3.c:hack_print the register file pointer variable fp is handled incorrectly during the call to print_simple.This required preprocessing out the register directive.--------NOTE 2: The original sources assume the existence of certain library functionsstandard to Berkeley Unix compatible C compilers. A minimal implementationof these functions is contained in the file gnufuncts.c, not part of theoriginal sources. :MPW:MPW Tools:Tools with Source:gawk ƒ:obstack.c
#define register1/* obstack.c - subroutines used implicitly by object stack macros Copyright (c) 1986 Free Software Foundation, Inc. NO WARRANTY BECAUSE THIS PROGRAM IS LICENSED FREE OF CHARGE, WE PROVIDE ABSOLUTELYNO WARRANTY, TO THE EXTENT PERMITTED BY APPLICABLE STATE LAW. EXCEPTWHEN OTHERWISE STATED IN WRITING, FREE SOFTWARE FOUNDATION, INC,RICHARD M. STALLMAN AND/OR OTHER PARTIES PROVIDE THIS PROGRAM "AS IS"WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING,BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY ANDFITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITYAND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVEDEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR ORCORRECTION. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW WILL RICHARD M.STALLMAN, THE FREE SOFTWARE FOUNDATION, INC., AND/OR ANY OTHER PARTYWHO MAY MODIFY AND REDISTRIBUTE THIS PROGRAM AS PERMITTED BELOW, BELIABLE TO YOU FOR DAMAGES, INCLUDING ANY LOST PROFITS, LOST MONIES, OROTHER SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THEUSE OR INABILITY TO USE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA ORDATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY THIRD PARTIES ORA FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS) THISPROGRAM, EVEN IF YOU HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCHDAMAGES, OR FOR ANY CLAIM BY ANY OTHER PARTY. GENERAL PUBLIC LICENSE TO COPY 1. You may copy and distribute verbatim copies of this source fileas you receive it, in any medium, provided that you conspicuously andappropriately publish on each copy a valid copyright notice "Copyright(C) 1986 Free Software Foundation, Inc."; and include following thecopyright notice a verbatim copy of the above disclaimer of warrantyand of this License. 2. You may modify your copy or copies of this source file orany portion of it, and copy and distribute such modifications underthe terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains or is a derivative of this program or any part thereof, to be freely distributed and licensed to all third parties on terms identical to those contained in this License Agreement (except that you may choose to grant more extensive warranty protection to third parties, at your option). 3. You may copy and distribute this program or any portion of it incompiled, executable or object code form under the terms of Paragraphs1 and 2 above provided that you do the following: a) cause each such copy to be accompanied by the corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) cause each such copy to be accompanied by a written offer, with no time limit, to give any third party free (except for a nominal shipping charge) a machine readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) in the case of a recipient of this program in compiled, executable or object code form (without the corresponding source code) you shall cause copies you distribute to be accompanied by a copy of the written offer of source code which you received along with the copy you received. 4. You may not copy, sublicense, distribute or transfer this programexcept as expressly provided under this License Agreement. Any attemptotherwise to copy, sublicense, distribute or transfer this program is void andyour rights to use the program under this License agreement shall beautomatically terminated. However, parties who have received computersoftware programs from you with this License Agreement will not havetheir licenses terminated so long as such parties remain in full compliance.*/#include "obstack.h"#include <stdio.h>#include <string.h>void dbprint();void_obstack_begin (h, chunkfun) struct obstack *h; void *(*chunkfun) ();{ register1 _Ll *chunk; /* points to new chunk */ chunk = h->chunk = (_Ll *) (*chunkfun) (h->chunk_size); h->next_free = h->object_base = chunk->obstack_l_0; h->chunk_limit = chunk->obstack_l_limit = (char *) chunk + h->chunk_size; chunk->obstack_l_prev = 0;}/* Allocate a new current chunk for the obstack *H on the assumption that LENGTH bytes need to be added to the current object, or a new object of length LENGTH allocated. Copies any partial object from the end of the old chunk to the beginning of the new one. */void_obstack_newchunk (h, chunkfun, length) struct obstack *h; void *(*chunkfun) (); int length;{ register1 _Ll *old_chunk = h->chunk; register1 _Ll *new_chunk; register1 long new_size; register1 int obj_size = h->next_free - h->object_b/* Compute size for new chunk. */ new_size = (obj_size + length) << 1; if (new_size < h->chunk_size) new_size = h->chunk_size; /* Allocate and initialize the new chunk. */ new_chunk = h->chunk = (_Ll *) (*chunkfun) (new_size); new_chunk->obstack_l_prev = old_chunk; new_chunk->obstack_l_limit = h->chunk_limit = (char *) new_chunk + new_size; /* Move the existing object to the new chunk. */ bcopy (h->object_base, new_chunk->obstack_l_0, obj_size); h->object_base = new_chunk->obstack_l_0; h->next_free = h->object_base + obj_size; }void_obstack_free (h, freechunkfun, obj) struct obstack *h; void (*freechunkfun) (); char *obj;{ register1 _Ll* lp; /* below addr of any objects in this chunk */ register1 _Ll* plp; /* point to previous chunk if any */ lp = (h)->chunk; while (lp != 0 && ((char *)lp > obj || (h)->chunk_limit < obj)) { plp = lp -> obstack_l_prev; (*freechunkfun) (lp); if(lp==plp) plp=0; lp = plp; } if (lp) { (h)->object_base = (h)->next_free = (char *)(obj); (h)->chunk_limit = lp->obstack_l_limit; (h)->chunk = lp; } else if (obj != 0) /* obj is not in any of the chunks! */ {abort ();}} :MPW:MPW Tools:Tools with Source:gawk ƒ:obstack.h
/* obstack.h - object stack macros Copyright (c) 1986 Free Software Foundation, Inc.Summary:All the apparent functions defined here are macros. The ideais that you would use these pre-tested macros to solve avery specific set of problems, and they would run fast.Caution: no side-effects in arguments please!! They may beevaluated MANY times!!These macros operate a stack of objects. Each object starts lifesmall, and may grow to maturity. (Consider building a word syllableby syllable.) An object can move while it is growing. Once it hasbeen "finished" it never changes address again. So the "top of thestack" is typically an immature growing object, while the rest of thestack is of mature, fixed size and fixed address objects.These routines grab large chunks of memory, using a function yousupply, called `obstack_chunk_alloc'. On occasion, they free chunks,by calling `obstack_chunk_free'. You must define them and declarethem before using any obstack macros.Each independent stack is represented by a `struct obstack'.Each of the obstack macros expects a pointer to such a structureas the first argument.One motivation for this package is the problem of growing char stringsin symbol tables. Unless you are "facist pig with a read-only mind"[Gosper's immortal quote from HAKMEM item 154, out of context] youwould not like to put any arbitrary upper limit on the length of yoursymbols.In practice this often means you will build many short symbols and afew long symbols. At the time you are reading a symbol you don't knowhow long it is. One traditional method is to read a symbol into abuffer, realloc()ating the buffer every time you try to read a symbolthat is longer than the buffer. This is beaut, but you still willwant to copy the symbol from the buffer to a more permanentsymbol-table entry say about half the time.With obstacks, you can work differently. Use one obstack for all symbolnames. As you read a symbol, grow the name in the obstack gradually.When the name is c finalize it. Then, if the symbol exists already,free the newly read name.The way we do this is to take a large chunk, allocating memory fromlow addresses. When you want to build a aymbol in the chunk you justadd chars above the current "high water mark" in the chunk. When youhave finished adding chars, because you got to the end of the symbol,you know how long the chars are, and you can create a new object.Mostly the chars will not burst over the highest address of the chunk,because you would typically expect a chunk to be (say) 100 times aslong as an average object.In case that isn't clear, when we have enough chars to make upthe object, THEY ARE ALREADY CONTIGUOUS IN THE CHUNK (guaranteed)so we just point to it where it lies. No moving of chars isneeded and this is the second win: potentially long strings neednever be explicitly shuffled. Once an object is formed, it does notchange its address during its lifetime.When the chars burst over a chunk boundary, we allocate a largerchunk, and then copy the partly formed object from the end of the oldchunk to the beggining of the new larger chunk. We then carry onaccreting characters to the end of the object as we normaly would.A special macro is provided to add a single char at a time to agrowing object. This allows the use of register variables, whichbreak the ordinary 'growth' macro.Summary: We allocate large chunks. We carve out one object at a time from the current chunk. Once carved, an object never moves. We are free to append data of any size to the currently growing object. Exactly one object is growing in an obstack at any one time. You can run one obstack per control block. You may have as many control blocks as you dare. Because of the way we do it, you can `unwind' a obstack back to a previous state. (You may remove objects much as you would with a stack.)*/#ifndef obstackH#define obstackH /* these #defines keep it brief */#define _Ll struct obstack_chunk#define _LL (8) /* _L length in chars */struct obstack_chunk /* Lives at front of each chunk. */{ char *obstack_l_limit; /* 1 past end of this chunk */ _Ll *obstack_l_prev; /* address of prior chunk or NULL */ char obstack_l_0[4]; /* objects begin here */};#if 0This function, called like malloc but not returning on failure,must return a chunk of the size given to it as argument,aligned on a boundary of 2**OBSTACK_LOG_DEFAULT_ALIGNMENT bytes.struct obstack_chunk * obstack_chunk_alloc();#endif /* 0 */struct obstack /* control current object in current chunk */{ long chunk_size; /* preferred size to allocate chunks in */ _Ll* chunk; /* address of current struct obstack_chunk */ char *object_base; /* address of object we are building */ char *next_free; /* where to add next char to current object */ char *chunk_limit; /* address of char after current chunk */ long temp; /* Temporary for some macros. */ long alignment_mask; /* Mask of alignment for each object. */};/* Pointer to beginning of object being allocated or to be allocated next. Note that this might not be the final address of the object because a new chunk might be needed to hold the final size. */#define obstack_base(h) ((h)->object_base)/* Pointer to next byte not yet allocated in current chunk. */#define obstack_next_free(h) ((h)->next_free)/* Size of object currently growing */#define obstack_object_size(h) ((h)->next_free - (h)->object_base)/* Mask specifying low bits that should be clear in address of an object. */#define obstack_alignment_mask(h) ((h)->alignment_mask)#define obstack_init(h) obstack_begin (h, 4096 - 4 - _LL)#define obstack_begin(h,try_length) \((h)->chunk_size = (try_length) + (_LL), \ (h)->alignment_mask = ((1 << 2) - 1), \ _obstack_begin ((h), obstack_chunk_alloc))#define obstack_grow(h,where,length) \( (h)->temp = (length), \ (((h)->next_free + (h)->temp > (h)->chunk_limit) \ ? _obstack_newchunk ((h), obstack_chunk_alloc, (h)->temp) : 0), \ bcopy (where, (h)->next_free, (h)->temp), \ (h)->next_free += (h)->temp)#define obstack_grow0(h,where,length) \( (h)->temp = (length), \ (((h)->next_free + (h)->temp + 1 > (h)->chunk_limit) \ ? _obstack_newchunk ((h), obstack_chunk_alloc, (h)->temp + 1) : 0), \ bcopy (where, (h)->next_free, (h)->temp), \ (h)->next_free += (h)->temp, \ *((h)->next_free)++ = 0)#define obstack_1grow(h,datum) \( (((h)->next_free + 1 > (h)->chunk_limit) \ ? _obstack_newchunk ((h), obstack_chunk_alloc, 1) : 0), \ *((h)->next_free)++ = (datum))#define obstack_blank(h,length) \( (h)->temp = (length), \ (((h)->next_free + (h)->temp > (h)->chunk_limit) \ ? _obstack_newchunk ((h), obstack_chunk_alloc, (h)->temp) : 0), \ (h)->next_free += (h)->temp)#define obstack_alloc(h,length) \ (obstack_blank ((h), (length)), obstack_finish (h))#define obstack_copy(h,where,length) \ (obstack_grow ((h), (where), (length)), obstack_finish (h))#define obstack_copy0(h,where,length) \ (obstack_grow0 ((h), (where), (length)), obstack_finish (h))#define obstack_room(h) ((long unsigned int) \ ((h)->chunk_limit - (h)->next_free))#define obstack_1grow_fast(h,achar) (*((h)->next_free)++ = achar)#define obstack_blank_fast(h,n) ((h)->next_free += (n))#define obstack_finish(h) \ ((h)->temp = (long) (h)->object_base, \ (h)->next_free \ = (char*)((long)((h)->next_free+(h)->alignment_mask) \ & ~ ((h)->alignment_mask)), \ (((h)->next_free - (char *)(h)->chunk \ > (h)->chunk_limit - (char *)(h)->chunk) \ ? (h)->next_free = (h)->chunk_limit : 0), \ (h)->object_base = (h)->next_free, \ (char *) (h)->temp)#define obstack_free(h,obj) \(((h)->temp = (char *)(obj) - (char *) (h)->chunk), \ (((h)->temp >= 0 && (h)->temp < (h)->chunk_limit - (char *) (h)->chunk)\ ? (long) ((h)->next_free = (h)->object_base \ = (h)->temp + (char *) (h)->chunk) \ : (long) _obstack_free ((h), obstack_chunk_free, \ (h)->temp + (char *) (h)->chunk)))#endif /* #ifndef obstackH */ :MPW:MPW Tools:Tools with Source:gawk ƒ:regex.c
#define register1/* Extended regular expression matching and search. Copyright (C) 1985 Free Software Foundation, Inc. NO WARRANTY BECAUSE THIS PROGRAM IS LICENSED FREE OF CHARGE, WE PROVIDE ABSOLUTELYNO WARRANTY, TO THE EXTENT PERMITTED BY APPLICABLE STATE LAW. EXCEPTWHEN OTHERWISE STATED IN WRITING, FREE SOFTWARE FOUNDATION, INC,RICHARD M. STALLMAN AND/OR OTHER PARTIES PROVIDE THIS PROGRAM "AS IS"WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING,BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY ANDFITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITYAND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVEDEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR ORCORRECTION. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW WILL RICHARD M.STALLMAN, THE FREE SOFTWARE FOUNDATION, INC., AND/OR ANY OTHER PARTYWHO MAY MODIFY AND REDISTRIBUTE THIS PROGRAM AS PERMITTED BELOW, BELIABLE TO YOU FOR DAMAGES, INCLUDING ANY LOST PROFITS, LOST MONIES, OROTHER SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THEUSE OR INABILITY TO USE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA ORDATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY THIRD PARTIES ORA FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS) THISPROGRAM, EVEN IF YOU HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCHDAMAGES, OR FOR ANY CLAIM BY ANY OTHER PARTY. GENERAL PUBLIC LICENSE TO COPY 1. You may copy and distribute verbatim copies of this source fileas you receive it, in any medium, provided that you conspicuously andappropriately publish on each copy a valid copyright notice "Copyright(C) 1985 Free Software Foundation, Inc."; and include following thecopyright notice a verbatim copy of the above disclaimer of warrantyand of this License. You may charge a distribution fee for thephysical act of transferring a copy. 2. You may modify your copy or copies of this source file orany portion of it, and copy and distribute such modifications underthe terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains or is a derivative of this program or any part thereof, to be licensed at no charge to all third parties on terms identical to those contained in this License Agreement (except that you may choose to grant more extensive warranty protection to some or all third parties, at your option). c) You may charge a distribution fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee.Mere aggregation of another unrelated program with this program (or itsderivative) on a volume of a storage or distribution medium does not bringthe other program under the scope of these terms. 3. You may copy and distribute this program (or a portion or derivativeof it, under Paragraph 2) in object code or executable form under the termsof Paragraphs 1 and 2 above provided that you also do one of the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal shipping charge) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.)For an executable file, complete source code means all the source code forall modules it contains; but, as a special exception, it need not includesource code for modules which are standard libraries that accompany theoperating system on which the executable file runs. 4. You may not copy, sublicense, distribute or transfer this programexcept as expressly provided under this License Agreement. Any attemptotherwise to copy, sublicense, distribute or transfer this program is void andyour rights to use the program under this License agreement shall beautomatically terminated. However, parties who have received computersoftware programs from you with this License Agreement will not havetheir licenses terminated so long as such parties remain in full compliance. 5. If you wish to incorporate parts of this program into other freeprograms whose distribution conditions are different, write to the FreeSoftware Foundation at 675 Mass Ave, Cambridge, MA 02139. We have not yetworked out a simple rule that can be stated here, but we will often permitthis. We will be guided by the two goals of preserving the free status ofall derivatives of our free software and of promoting the sharing and reuse ofsoftware.In other words, you are welcome to use, share and improve this program.You are forbidden to forbid anyone else to use, share and improvewhat you give them. Help stamp out software-hoarding! *//* To test, compile with -Dtest. This Dtestable feature turns this into a self-contained program which reads a pattern, describes how it compiles, then reads a string and searches for it. */#include <stdio.h>#include <string.h>void *malloc();void *realloc();void *alloca();#ifdef emacs/* The `emacs' switch turns on certain special matching commands that make sense only in emacs. */#include "config.h"#include "lisp.h"#include "buffer.h"#include "syntax.h"#else /* not emacs *//* * Define the syntax stuff, so we can do the \<...\> things. */#ifndef Sword /* must be non-zero in some of the tests below... */#define Sword 1#endif#define SYNTAX(c) re_syntax_table[c]#ifdef SYNTAX_TABLEchar *re_syntax_table;#elsestatic char re_syntax_table[256];static voidinit_syntax_once (){ register1 int c; static int done = 0; if (done) return; bzero (re_syntax_table, sizeof re_syntax_table); for (c = 'a'; c <= 'z'; c++) re_syntax_table[c] = Sword; for (c = 'A'; c <= 'Z'; c++) re_syntax_table[c] = Sword; for (c = '0'; c <= '9'; c++) re_syntax_table[c] = Sword; done = 1;}#endif /* SYNTAX_TABLE */#endif /* not emacs */#include "regex.h"/* Number of failure points to allocate space for initially, when matching. If this number is exceeded, more space is allocated, so it is not a hard limit. */#ifndef NFAILURES#define NFAILURES 80#endif NFAILURES/* width of a byte in bits */#define BYTEWIDTH 8#ifndef SIGN_EXTEND_CHAR#define SIGN_EXTEND_CHAR(x) (x)#endifstatic int obscure_syntax = 0;/* Specify the precise syntax of regexp for compilation. This provides for compatibility for various utilities which historically have different, incompatible syntaxes. The argument SYNTAX is a bit-mask containing the two bits RE_NO_BK_PARENS and RE_NO_BK_VBAR. */intre_set_syntax (syntax){ int ret; ret = obscure_syntax; obscure_syntax = syntax; return ret;}/* re_compile_pattern takes a regular-expression string and converts it into a buffer full of byte commands for matching. PATTERN is the address of the pattern string SIZE is the length of it. BUFP is a struct re_pattern_buffer * which points to the info on where to store the byte commands. This structure contains a char * which points to the actual space, which should have been obtained with malloc. re_compile_pattern may use realloc to grow the buffer space. The number of bytes of commands can be found out by looking in the struct re_pattern_buffer that bufp pointed to, after re_compile_pattern returns.*/#define PATPUSH(ch) (*b++ = (char) (ch))#define PATFETCH(c) \ {if (p == pend) goto end_of_pattern; \ c = * (unsigned char *) p++; \ if (translate) c = translate[c]; }#define PATFETCH_RAW(c) \ {if (p == pend) goto end_of_pattern; \ c = * (unsigned char *) p++; }#define PATUNFETCH p--#define EXTEND_BUFFER \ { char *old_buffer = bufp->buffer;\ long c;\ if (bufp->allocated == (1l<<16)) goto too_big; \ bufp->allocated *= 2; \ if (bufp->allocated > (1l<<16)) bufp->allocated = (1l<<16); \ if (!(bufp->buffer = (char *) realloc (bufp->buffer, (int)bufp->allocated))) \ goto memory_exhausted; \ c = bufp->buffer - old_buffer; \ b += c; \ if (fixup_jump) \ fixup_jump += c; \ if (laststart) \ laststart += c; \ begalt += c; \ if (pending_exact) \ pending_exact += c; \ }static int store_jump (), insert_jump ();char *re_compile_pattern (pattern, size, bufp) char *pattern; int size; struct re_pattern_buffer *bufp;{ register1 char *b = bufp->buffer; register1 char *p = pattern; char *pend = pattern + size; register1 unsigned c, c1; char *p1; unsigned char *translate = (unsigned char *) bufp->translate; /* address of the count-byte of the most recently inserted "exactn" command. This makes it possible to tell whether a new exact-match character can be added to that command or requires a new "exactn" command. */ char *pending_exact = 0; /* address of the place where a forward-jump should go to the end of the containing expression. Each alternative of an "or", except the last, ends with a forward-jump of this sort. */ char *fixup_jump = 0; /* address of start of the most recently finished expression. This tells postfix * where to find the start of its operand. */ char *laststart = 0; /* In processing a repeat, 1 means zero matches is allowed */ char zero_times_ok; /* In processing a repeat, 1 means many matches is allowed */ char many_times_ok; /* address of beginning of regexp, or inside of last \( */ char *begalt = b; /* Stack of information saved by \( and restored by \). Four stack elements are pushed by each \(: First, the value of b. Second, the value of fixup_jump. Third, the value of regnum. Fourth, the value of begalt. */ int stackb[40]; int *stackp = stackb; int *stacke = stackb + 40; int *stackt; /* Counts \('s as they are encountered. Remembered for the matching \), where it becomes the "register number" to put in the stop_memory command */ int regnum = 1; bufp->fastmap_accurate = 0;#ifndef emacs#ifndef SYNTAX_TABLE /* * Initialize the syntax table. */ init_syntax_once();#endif#endif if (bufp->allocated == 0) { bufp->allocated = 28; if (bufp->buffer) /* EXTEND_BUFFER loses when bufp->allocated is 0 */ bufp->buffer = (char *) realloc (bufp->buffer, 28); else /* Caller did not allocate a buffer. Do it for him */ bufp->buffer = (char *) malloc (28); if (!bufp->buffer) goto memory_exhausted; begalt = b = bufp->buffer; } while (p != pend) { if (b - bufp->buffer > bufp->allocated - 10) /* Note that EXTEND_BUFFER clobbers c */ EXTEND_BUFFER; PATFETCH (c); switch (c) { case '$': if (obscure_syntax & RE_TIGHT_VBAR) { if (! (obscure_syntax & RE_CONTEXT_INDEP_OPS) && p != pend) goto normal_char; /* Make operand of last vbar end before this `$'. */ if (fixup_jump) store_jump (fixup_jump, jump, b); fixup_jump = 0; PATPUSH (endline); break; } /* $ means succeed if at end of line, but only in special contexts. If randomly in the middle of a pattern, it is a normal character. */ if (p == pend || (obscure_syntax & RE_CONTEXT_INDEP_OPS) || (obscure_syntax & RE_NO_BK_PARENS ? *p == ')' : *p == '\\' && p[1] == ')') || (obscure_syntax & RE_NO_BK_VBAR ? *p == '|' : *p == '\\' && p[1] == '|')) { PATPUSH (endline); break; } goto normal_char; case '^': /* ^ means succeed if at beg of line, but only if no preceding pattern. */ if (laststart && ! (obscure_syntax & RE_CONTEXT_INDEP_OPS)) goto normal_char; if (obscure_syntax & RE_TIGHT_VBAR) { if (p != pattern + 1 && ! (obscure_syntax & RE_CONTEXT_INDEP_OPS)) goto normal_char; PATPUSH (begline); begalt = b; } else PATPUSH (begline); break; case '+': case '?': if (obscure_syntax & RE_BK_PLUS_QM) goto normal_char; handle_plus: case '*': /* If there is no previous pattern, char not special. */ if (!laststart && ! (obscure_syntax & RE_CONTEXT_INDEP_OPS)) goto normal_char; /* If there is a sequence of repetition chars, collapse it down to equivalent to just one. */ zero_times_ok = 0; many_times_ok = 0; while (1) { zero_times_ok |= c != '+'; many_times_ok |= c != '?'; if (p == pend) break; PATFETCH (c); if (!(c == '*' || c == '+' || c == '?')) { PATUNFETCH; break; } } /* Now we know whether 0 matches is allowed, and whether 2 or more matches is allowed. */ if (many_times_ok) { /* If more than one repetition is allowed, put in a backward jump at the end. */ store_jump (b, maybe_finalize_jump, laststart - 3); b += 3; } insert_jump (on_failure_jump, laststart, b + 3, b); pending_exact = 0; b += 3; if (!zero_times_ok) { /* At least one repetition required: insert before the loop a skip over the initial on-failure-jump instruction */ insert_jump (dummy_failure_jump, laststart, laststart + 6, b); b += 3; } break; case '.': laststart = b; PATPUSH (anychar); break; case '[': while (b - bufp->buffer > bufp->allocated - 3 - (1 << BYTEWIDTH) / BYTEWIDTH) /* Note that EXTEND_BUFFER clobbers c */ EXTEND_BUFFER; laststart = b; if (*p == '^') PATPUSH (charset_not), p++; else PATPUSH (charset); p1 = p; PATPUSH ((1 << BYTEWIDTH) / BYTEWIDTH); /* Clear the whole map */ bzero (b, (1 << BYTEWIDTH) / BYTEWIDTH); /* Read in characters and ranges, setting map bits */ while (1) { PATFETCH (c); if (c == ']' && p != p1 + 1) break; if (*p == '-' && p[1] != ']') { PATFETCH (c1); PATFETCH (c1); while (c <= c1) b[c / BYTEWIDTH] |= 1 << (c % BYTEWIDTH), c++; } else { b[c / BYTEWIDTH] |= 1 << (c % BYTEWIDTH); } } /* Discard any bitmap bytes that are all 0 at the end of the map. Decrement the map-length byte too. */ while (b[-1] > 0 && b[b[-1] - 1] == 0) b[-1]--; b += b[-1]; break; case '(': if (! (obscure_syntax & RE_NO_BK_PARENS)) goto normal_char; else goto handle_open; case ')': if (! (obscure_syntax & RE_NO_BK_PARENS)) goto normal_char; else goto handle_close; case '\n': if (! (obscure_syntax & RE_NEWLINE_OR)) goto normal_char; else goto handle_bar; case '|': if (! (obscure_syntax & RE_NO_BK_VBAR)) goto normal_char; else goto handle_bar; case '\\': if (p == pend) goto invalid_pattern; PATFETCH_RAW (c); switch (c) { case '(': if (obscure_syntax & RE_NO_BK_PARENS) goto normal_backsl; handle_open: if (stackp == stacke) goto nesting_too_deep; if (regnum < RE_NREGS) { PATPUSH (start_memory); PATPUSH (regnum); } *stackp++ = b - bufp->buffer; *stackp++ = fixup_jump ? fixup_jump - bufp->buffer + 1 : 0; *stackp++ = regnum++; *stackp++ = begalt - bufp->buffer; fixup_ju
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:gawk ƒ:regex.c
+++++ Continued from previous card +++++
mp = 0; laststart = 0; begalt = b; break; case ')': if (obscure_syntax & RE_NO_BK_PARENS) goto normal_backsl; handle_close: if (stackp == stackb) goto unmatched_close; begalt = *--stackp + bufp->buffer; if (fixup_jump) store_jump (fixup_jump, jump, b); if (stackp[-1] < RE_NREGS) { PATPUSH (stop_memory); PATPUSH (stackp[-1]); } stackp -= 2; fixup_jump = 0; if (*stackp) fixup_jump = *stackp + bufp->buffer - 1; laststart = *--stackp + bufp->buffer; break; case '|': if (obscure_syntax & RE_NO_BK_VBAR) goto normal_backsl; handle_bar: insert_jump (on_failure_jump, begalt, b + 6, b); pending_exact = 0; b += 3; if (fixup_jump) store_jump (fixup_jump, jump, b); fixup_jump = b; b += 3; laststart = 0; begalt = b; break;#ifdef emacs case '=': PATPUSH (at_dot); break; case 's': laststart = b; PATPUSH (syntaxspec); PATFETCH (c); PATPUSH (syntax_spec_code[c]); break; case 'S': laststart = b; PATPUSH (notsyntaxspec); PATFETCH (c); PATPUSH (syntax_spec_code[c]); break;#endif emacs case 'w': laststart = b; PATPUSH (wordchar); break; case 'W': laststart = b; PATPUSH (notwordchar); break; case '<': PATPUSH (wordbeg); break; case '>': PATPUSH (wordend); break; case 'b': PATPUSH (wordbound); break; case 'B': PATPUSH (notwordbound); break; case '`': PATPUSH (begbuf); break; case '\'': PATPUSH (endbuf); break; case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': c1 = c - '0'; if (c1 >= regnum) goto normal_char; for (stackt = stackp - 2; stackt > stackb; stackt -= 4) if (*stackt == c1) goto normal_char; laststart = b; PATPUSH (duplicate); PATPUSH (c1); break; case '+': case '?': if (obscure_syntax & RE_BK_PLUS_QM) goto handle_plus; default: normal_backsl: /* You might think it would be useful for \ to mean not to translate; but if we don't translate it it will never match anything. */ if (translate) c = translate[c]; goto normal_char; } break; default: normal_char: if (!pending_exact || pending_exact + *pending_exact + 1 != b || *pending_exact == 0177 || *p == '*' || *p == '^' || ((obscure_syntax & RE_BK_PLUS_QM) ? *p == '\\' && (p[1] == '+' || p[1] == '?') : (*p == '+' || *p == '?'))) { laststart = b; PATPUSH (exactn); pending_exact = b; PATPUSH (0); } PATPUSH (c); (*pending_exact)++; } } if (fixup_jump) store_jump (fixup_jump, jump, b); if (stackp != stackb) goto unmatched_open; bufp->used = b - bufp->buffer; return 0; invalid_pattern: return "Invalid regular expression"; unmatched_open: return "Unmatched \\("; unmatched_close: return "Unmatched \\)"; end_of_pattern: return "Premature end of regular expression"; nesting_too_deep: return "Nesting too deep"; too_big: return "Regular expression too big"; memory_exhausted: return "Memory exhausted";}/* Store where `from' points a jump operation to jump to where `to' points. `opcode' is the opcode to store. */static intstore_jump (from, opcode, to) char *from, *to; char opcode;{ from[0] = opcode; from[1] = (to - (from + 3)) & 0377; from[2] = (to - (from + 3)) >> 8;}/* Open up space at char FROM, and insert there a jump to TO. CURRENT_END gives te end of the storage no in use, so we know how much data to copy up. OP is the opcode of the jump to insert. If you call this function, you must zero out pending_exact. */static intinsert_jump (op, from, to, current_end) char op; char *from, *to, *current_end;{ register1 char *pto = current_end + 3; register1 char *pfrom = current_end; while (pfrom != from) *--pto = *--pfrom; store_jump (from, op, to);}/* Given a pattern, compute a fastmap from it. The fastmap records which of the (1 << BYTEWIDTH) possible characters can start a string that matches the pattern. This fastmap is used by re_search to skip quickly over totally implausible text. The caller must supply the address of a (1 << BYTEWIDTH)-byte data area as bufp->fastmap. The other components of bufp describe the pattern to be used. */voidre_compile_fastmap (bufp) struct re_pattern_buffer *bufp;{ unsigned char *pattern = (unsigned char *) bufp->buffer; int size = bufp->used; register1 char *fastmap = bufp->fastmap; register1 unsigned char *p = pattern; register1 unsigned char *pend = pattern + size; register1 int j, k; unsigned char *translate = (unsigned char *) bufp->translate; unsigned char *stackb[NFAILURES]; unsigned char **stackp = stackb; bzero (fastmap, (1 << BYTEWIDTH)); bufp->fastmap_accurate = 1; bufp->can_be_null = 0; while (p) { if (p == pend) { bufp->can_be_null = 1; break; }#ifdef SWITCH_ENUM_BUG switch ((int) ((enum regexpcode) *p++))#else switch ((enum regexpcode) *p++)#endif { case exactn: if (translate) fastmap[translate[p[1]]] = 1; else fastmap[p[1]] = 1; break; case begline: case before_dot: case at_dot: case after_dot: case begbuf: case endbuf: case wordbound: case notwordbound: case wordbeg: case wordend: continue; case endline: if (translate) fastmap[translate['\n']] = 1; else fastmap['\n'] = 1; if (bufp->can_be_null != 1) bufp->can_be_null = 2; break; case finalize_jump: case maybe_finalize_jump: case jump: case dummy_failure_jump: bufp->can_be_null = 1; j = *p++ & 0377; j += SIGN_EXTEND_CHAR (*(char *)p) << 8; p += j + 1; /* The 1 compensates for missing ++ above */ if (j > 0) continue; /* Jump backward reached implies we just went through the body of a loop and matched nothing. Opcode jumped to should be an on_failure_jump. Just treat it like an ordinary jump. For a * loop, it has pushed its failure point already; if so, discard that as redundant. */ if ((enum regexpcode) *p != on_failure_jump) continue; p++; j = *p++ & 0377; j += SIGN_EXTEND_CHAR (*(char *)p) << 8; p += j + 1; /* The 1 compensates for missing ++ above */ if (stackp != stackb && *stackp == p) stackp--; continue; case on_failure_jump: j = *p++ & 0377; j += SIGN_EXTEND_CHAR (*(char *)p) << 8; p++; *++stackp = p + j; continue; case start_memory: case stop_memory: p++; continue; case duplicate: bufp->can_be_null = 1; fastmap['\n'] = 1; case anychar: for (j = 0; j < (1 << BYTEWIDTH); j++) if (j != '\n') fastmap[j] = 1; if (bufp->can_be_null) return; /* Don't return; check the alternative paths so we can set can_be_null if appropriate. */ break; case wordchar: for (j = 0; j < (1 << BYTEWIDTH); j++) if (SYNTAX (j) == Sword) fastmap[j] = 1; break; case notwordchar: for (j = 0; j < (1 << BYT j++) if (SYNTAX (j) != Sword) fastmap[j] = 1; break;#ifdef emacs case syntaxspec: k = *p++; for (j = 0; j < (1 << BYTEWIDTH); j++) if (SYNTAX (j) == (enum syntaxcode) k) fastmap[j] = 1; break; case notsyntaxspec: k = *p++; for (j = 0; j < (1 << BYTEWIDTH); j++) if (SYNTAX (j) != (enum syntaxcode) k) fastmap[j] = 1; break;#endif emacs case charset: for (j = *p++ * BYTEWIDTH - 1; j >= 0; j--) if (p[j / BYTEWIDTH] & (1 << (j % BYTEWIDTH))) { if (translate) fastmap[translate[j]] = 1; else fastmap[j] = 1; } break; case charset_not: /* Chars beyond end of map must be allowed */ for (j = *p * BYTEWIDTH; j < (1 << BYTEWIDTH); j++) if (translate) fastmap[translate[j]] = 1; else fastmap[j] = 1; for (j = *p++ * BYTEWIDTH - 1; j >= 0; j--) if (!(p[j / BYTEWIDTH] & (1 << (j % BYTEWIDTH)))) { if (translate) fastmap[translate[j]] = 1; else fastmap[j] = 1; } break; } /* Get here means we have successfully found the possible starting characters of one path of the pattern. We need not follow this path any farther. Instead, look at the next alternative remembered in the stack. */ if (stackp != stackb) p = *stackp--; else break; }}/* Like re_search_2, below, but only one string is specified. */intre_search (pbufp, string, size, startpos, range, regs) struct re_pattern_buffer *pbufp; char *string; int size, startpos, range; struct re_registers *regs;{ return re_search_2 (pbufp, (char *)0, 0, string, size, startpos, range, regs, size);}/* Like re_match_2 but tries first a match starting at index STARTPOS, then at STARTPOS + 1, and so on. RANGE is the number of places to try before giving up. If RANGE is negative, the starting positions tried are STARTPOS, STARTPOS - 1, etc. It is up to the caller to make sure that range is not so large as to take the starting position outside of the input strings.The value returned is the position at which the match was found, or -1 if no match was found, or -2 if error (such as failure stack overflow). */intre_search_2 (pbufp, string1, size1, string2, size2, startpos, range, regs, mstop) struct re_pattern_buffer *pbufp; char *string1, *string2; int size1, size2; int startpos; register1 int range; struct re_registers *regs; int mstop;{ register1 char *fastmap = pbufp->fastmap; register1 unsigned char *translate = (unsigned char *) pbufp->translate; int total = size1 + size2; int val; int save_register; /* Update the fastmap now if not correct already */ if (fastmap && !pbufp->fastmap_accurate) re_compile_fastmap (pbufp); /* Don't waste time in a long search for a pattern that says it is anchored. */ if (pbufp->used > 0 && (enum regexpcode) pbufp->buffer[0] == begbuf && range > 0) { if (startpos > 0) return -1; else range = 1; } while (1) { /* If a fastmap is supplied, skip quickly over characters that cannot possibly be the start of a match. Note, however, that if the pattern can possibly match the null string, we must test it at each starting point so that we take the first null string we get. */ if (fastmap && startpos < total && pbufp->can_be_null != 1) { if (range > 0) { register1 int lim = 0; register1 unsigned char *p; int irange = range; if (startpos < size1 && startpos + range >= size1) lim = range - (size1 - startpos); p = ((unsigned char *) &(startpos >= size1 ? string2 - size1 : string1)[startpos]); if (translate) { while (range > lim && !fastmap[translate[*p++]]) range--; } else { while (range > lim && !fastmap[*p++]) range--; } startpos += irange - range; } else { register1 unsigned char c; if (startpos >= size1) c = string2[startpos - size1]; else c = string1[startpos]; c &= 0xff; if (translate ? !fastmap[translate[c]] : !fastmap[c]) goto advance; } } if (range >= 0 && startpos == total && fastmap && pbufp->can_be_null == 0) return -1; save_register=range; val = re_match_2 (pbufp, string1, size1, string2, size2, startpos, regs, mstop); range=save_register; if (0 <= val) return startpos; if (val == -2) return -2; #ifdef C_ALLOCA alloca ((long) 0);#endif /* C_ALLOCA */ advance: if (!range) break; if (range > 0) range--, startpos++; else range++, startpos--; } return -1;}#ifndef emacs /* emacs never uses this */intre_match (pbufp, string, size, pos, regs) struct re_pattern_buffer *pbufp; char *string; int size, pos; struct re_registers *regs;{ return re_match_2 (pbufp,(char *)0, 0, string, size, pos, regs, size);}#endif /* emacs *//* Maximum size of failure stack. Beyond this, overflow is an error. */int re_max_failures = 2000;/* Match the pattern described by PBUFP against data which is the virtual concatenation of STRING1 and STRING2. SIZE1 and SIZE2 are the sizes of the two data strings. Start the match at position POS. Do not consider matching past the position MSTOP. If pbufp->fastmap is nonzero, then it had better be up to date. The reason that the data to match are specified as two components which are to be regarded as concatenated is so this function can be used directly on the contents of an Emacs buffer. -1 is returned if there is no match. -2 is returned if there is an error (such as match stack overflow). Otherwise the value is the length of the substring which was matched. */intre_match_2 (pbufp, string1, size1, string2, size2, pos, regs, mstop) struct re_pattern_buffer *pbufp; unsigned char *string1, *string2; int size1, size2; int pos; struct re_registers *regs; int mstop;{ register1 unsigned char *p = (unsigned char *) pbufp->buffer; register1 unsigned char *pend = p + pbufp->used; /* End of first string */ unsigned char *end1; /* End of second string */ unsigned char *end2; /* Pointer just past last char to consider matching */ unsigned char *end_match_1, *end_match_2; register1 unsigned char *d, *dend; register1 int mcnt; unsigned char *translate = (unsigned char *) pbufp->translate; /* Failure point stack. Each place that can handle a failure further down the line pushes a failure point on this stack. It consists of two char *'s. The first one pushed is where to resume scanning the pattern; the second pushed is where to resume scanning the strings. If the latter is zero, the failure point is a "dummy". If a failure happens and the innermost failure point is dormant, it discards that failure point and tries the next one. */ unsigned char **stackb = (unsigned char **) alloca ((long) 2 * NFAILURES * sizeof (char *)); unsigned char **stackp = stackb, **stacke = &stackb[2 * NFAILURES]; /* Information on the "contents" of registers. These are pointers into the input strings; they record just what was matched (on this attempt) by some part of the pattern. The start_memory command stores the start of a register's contents and the stop_memory command stores the end. At that point, regstart[regnum] points to the first character in the register, regend[regnum] points to the first character beyond the end of the register, regstart_seg1[regnum] is true iff regstart[regnum] points into string1, and regend_seg1[regnum] is true iff regend[regnum] points into string1. */ unsigned char *regstart[RE_NREGS]; unsigned char *regend[RE_NREGS]; unsigned char regstart_seg1[RE_NREGS], regend_seg1[RE_NREGS]; /* Set up pointers to ends of strings. Don't allow the second string to be empty unless both are empty. */ if (!size2) { string2 = string1; size2 = size1; string1 = 0; size1 = 0; } end1 = string1 + size1; end2 = string2 + size2; /* Compute where to stop matching, within the two strings */ if (mstop <= size1) { end_match_1 = string1 + mstop; end_match_2 = string2; } else { end_match_1 = end1; end_match_2 = string2 + mstop - size1; } /* Initi
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:gawk ƒ:regex.c
+++++ Continued from previous card +++++
alize \) text positions to -1 to mark ones that no \( or \) has been seen for. */ for (mcnt = 0; mcnt < sizeof (regend) / sizeof (*regend); mcnt++) regend[mcnt] = (unsigned char *) -1; /* `p' scans through the pattern as `d' scans through the data. `dend' is the end of the input string that `d' points within. `d' is advanced into the following input string whenever necessary, but this happens before fetching; therefore, at the beginning of the loop, `d' can be pointing at the end of a string, but it cannot equal string2. */ if (pos <= size1) d = string1 + pos, dend = end_match_1; else d = string2 + pos - size1, dend = end_match_2;/* Write PREFETCH; just before fetching a character with *d. */#define PREFETCH \ while (d == dend) \ { if (dend == end_match_2) goto fail; /* end of string2 => failure */ \ d = string2; /* end of string1 => advance to string2. */ \ dend = end_match_2; } /* This loop loops over pattern commands. It exits by returning from the function if match is complete, or it drops through if match fails at this starting point in the input data. */ while (1) { if (p == pend) /* End of pattern means we have succeeded! */ { /* If caller wants register contents data back, convert it to indices */ if (regs) { regs->start[0] = pos; if (dend == end_match_1) regs->end[0] = d - string1; else regs->end[0] = d - string2 + size1; for (mcnt = 1; mcnt < RE_NREGS; mcnt++) { if (regend[mcnt] == (unsigned char *) -1) { regs->start[mcnt] = -1; regs->end[mcnt] = -1; continue; } if (regstart_seg1[mcnt]) regs->start[mcnt] = regstart[mcnt] - string1; else regs->start[mcnt] = regstart[mcnt] - string2 + size1; if (regend_seg1[mcnt]) regs->end[mcnt] = regend[mcnt] - string1; else regs->end[mcnt] = regend[mcnt] - string2 + size1; } } if (dend == end_match_1) return (d - string1 - pos); else return d - string2 + size1 - pos; } /* Otherwise match next pattern command */#ifdef SWITCH_ENUM_BUG switch ((int) ((enum regexpcode) *p++))#else switch ((enum regexpcode) *p++)#endif { /* \( is represented by a start_memory, \) by a stop_memory. Both of those commands contain a "register number" argument. The text matched within the \( and \) is recorded under that number. Then, \<digit> turns into a `duplicate' command which is followed by the numeric value of <digit> as the register number. */ case start_memory: regstart[*p] = d; regstart_seg1[*p++] = (dend == end_match_1); break; case stop_memory: regend[*p] = d; regend_seg1[*p++] = (dend == end_match_1); break; case duplicate: { int regno = *p++; /* Get which register to match against */ register1 unsigned char *d2, *dend2; d2 = regstart[regno]; dend2 = ((regstart_seg1[regno] == regend_seg1[regno]) ? regend[regno] : end_match_1); while (1) { /* Advance to next segment in register contents, if necessary */ while (d2 == dend2) { if (dend2 == end_match_2) break; if (dend2 == regend[regno]) break; d2 = string2, dend2 = regend[regno]; /* end of string1 => advance to string2. */ } /* At end of register contents => success */ if (d2 == dend2) break; /* Advance to next segment in data being matched, if necessary */ PREFETCH; /* mcnt gets # consecutive chars to compare */ mcnt = dend - d; if (mcnt > dend2 - d2) mcnt = dend2 - d2; /* Compare that many; failure if mismatch, else skip them. */ if (translate ? bcmp_translate (d, d2, mcnt, translate) : bcmp (d, d2, mcnt)) goto fail; d += mcnt, d2 += mcnt; } } break; case anychar: /* fetch a data character */ PREFETCH; /* Match anything but a newline. */ if ((translate ? translate[*d++] : *d++) == '\n') goto fail; break; case charset: case charset_not: { /* Nonzero for charset_not */ int not = 0; register1 int c; if (*(p - 1) == (unsigned char) charset_not) not = 1; /* fetch a data character */ PREFETCH; if (translate) c = translate [*d]; else c = *d; if (c < *p * BYTEWIDTH && p[1 + c / BYTEWIDTH] & (1 << (c % BYTEWIDTH))) not = !not; p += 1 + *p; if (!not) goto fail; d++; break; } case begline: if (d == string1 || d[-1] == '\n') break; goto fail; case endline: if (d == end2 || (d == end1 ? (size2 == 0 || *string2 == '\n') : *d == '\n')) break; goto fail; /* "or" constructs ("|") are handled by starting each alternative with an on_failure_jump that points to the start of the next alternative. Each alternative except the last ends with a jump to the joining point. (Actually, each jump except for the last one really jumps to the following jump, because tensioning the jumps is a hassle.) */ /* The start of a stupid repeat has an on_failure_jump that points past the end of the repeat text. This makes a failure point so that, on failure to match a repetition, matching restarts past as many repetitions have been found with no way to fail and look for another one. */ /* A smart repeat is similar but loops back to the on_failure_jump so that each repetition makes another failure point. */ case on_failure_jump: if (stackp == stacke) { unsigned char **stackx; if (stacke - stackb > re_max_failures) return -2; stackx = (unsigned char **) alloca ((long) 2 * (stacke - stackb) * sizeof (char *)); bcopy (stackb, stackx, (stacke - stackb) * sizeof (char *)); stackp += stackx - stackb; stacke = stackx + 2 * (stacke - stackb); stackb = stackx; } mcnt = *p++ & 0377; mcnt += SIGN_EXTEND_CHAR (*(char *)p) << 8; p++; *stackp++ = mcnt + p; *stackp++ = d; break; /* The end of a smart repeat has an maybe_finalize_jump back. Change it either to a finalize_jump or an ordinary jump. */ case maybe_finalize_jump: mcnt = *p++ & 0377; mcnt += SIGN_EXTEND_CHAR (*(char *)p) << 8; p++; /* Compare what follows with the begining of the repeat. If we can establish that there is nothing that they would both match, we can change to finalize_jump */ if (p == pend) p[-3] = (unsigned char) finalize_jump; else if (*p == (unsigned char) exactn || *p == (unsigned char) endline) { register1 int c = *p == (unsigned char) endline ? '\n' : p[2]; register1 unsigned char *p1 = p + mcnt; /* p1[0] ... p1[2] are an on_failure_jump. Examine what follows that */ if (p1[3] == (unsigned char) exactn && p1[5] != c) p[-3] = (unsigned char) finalize_jump; else if (p1[3] == (unsigned char) charset || p1[3] == (unsigned char) charset_not) { int not = p1[3] == (unsigned char) charset_not; if (c < p1[4] * BYTEWIDTH && p1[5 + c / BYTEWIDTH] & (1 << (c % BYTEWIDTH))) not = !not; /* not is 1 if c would match */ /* That means it is not safe to finalize */ if (!not) p[-3] = (unsigned char) finalize_jump; } } p -= 2; if (p[-1] != (unsigned char) finalize_jump) { p[-1] = (unsigned char) jump; goto nofinalize; } /* The end of a stupid repeat has a finalize-jump back to the start, where another failure point will be made which will point after all the repetitions found so far. */ case finalize_jump: stackp -= 2; case jump: nofinalize: mcnt = *p++ & 0377; mcnt += SIGN_EXTEND_CHAR (*(char *)p) << 8; p += mcnt + 1; /* The 1 compensates for missing ++ above */ break; case dummy_failure_jump: if (stackp == stacke) { unsigned char **stackx = (unsigned char **) alloca ((long) 2 * (stacke - stackb) * sizeof (char *)); bcopy (stackb, stackx, (stacke - stackb) * sizeof (char *)); stackp += stackx - stackb; stacke = stackx + 2 * (stacke - stackb); stackb = stackx; } *stackp++ = 0; *stackp++ = 0; goto nofinalize; case wordbound: if (d == string1 /* Points to first char */ || d == end2 /* Points to end */ || (d == end1 && size2 == 0)) /* Points to end */ break; if ((SYNTAX (d[-1]) == Sword) != (SYNTAX (d == end1 ? *string2 : *d) == Sword)) break; goto fail; case notwordbound: if (d == string1 /* Points to first char */ || d == end2 /* Points to end */ || (d == end1 && size2 == 0)) /* Points to end */ goto fail; if ((SYNTAX (d[-1]) == Sword) != (SYNTAX (d == end1 ? *string2 : *d) == Sword)) goto fail; break; case wordbeg: if (d == end2 /* Points to end */ || (d == end1 && size2 == 0) /* Points to end */ || SYNTAX (* (d == end1 ? string2 : d)) != Sword) /* Next char not a letter */ goto fail; if (d == string1 /* Points to first char */ || SYNTAX (d[-1]) != Sword) /* prev char not letter */ break; goto fail; case wordend: if (d == string1 /* Points to first char */ || SYNTAX (d[-1]) != Sword) /* prev char not letter */ goto fail; if (d == end2 /* Points to end */ || (d == end1 && size2 == 0) /* Points to end */ || SYNTAX (d == end1 ? *string2 : *d) != Sword) /* Next char not a letter */ break; goto fail;#ifdef emacs case before_dot: if (((d - string2 <= (unsigned) size2) ? d - bf_p2 : d - bf_p1) <= point) goto fail; break; case at_dot: if (((d - string2 <= (unsigned) size2) ? d - bf_p2 : d - bf_p1) == point) goto fail; break; case after_dot: if (((d - string2 <= (unsigned) size2) ?p2 : d - bf_p1) >= point) goto fail; break; case wordchar: mcnt = (int) Sword; goto matchsyntax; case syntaxspec: mcnt = *p++; matchsyntax: PREFETCH; if (SYNTAX (*d++) != (enum syntaxcode) mcnt) goto fail; break; case notwordchar: mcnt = (int) Sword; goto matchnotsyntax; case notsyntaxspec: mcnt = *p++; matchnotsyntax: PREFETCH; if (SYNTAX (*d++) == (enum syntaxcode) mcnt) goto fail; break;#else case wordchar: PREFETCH; if (SYNTAX (*d++) == 0) goto fail; break; case notwordchar: PREFETCH; if (SYNTAX (*d++) != 0) goto fail; break;#endif not emacs case begbuf: if (d == string1) /* Note, d cannot equal string2 */ break; /* unless string1 == string2. */ goto fail; case endbuf: if (d == end2 || (d == end1 && size2 == 0)) break; goto fail; case exactn: /* Match the next few pattern characters exactly. mcnt is how many characters to match. */ mcnt = *p++; if (translate) { do { PREFETCH; if (translate[*d++] != *p++) goto fail; } while (--mcnt); } else { do { PREFETCH; if (*d++ != *p++) goto fail; } while (--mcnt); } break; } continue; /* Successfully matched one pattern command; keep matching */ /* Jump here if any matching operation fails. */ fail: if (stackp != stackb) /* A restart point is known. Restart there and pop it. */ { if (!stackp[-2]) { /* If innermost failure point is dormant, flush it and keep looking */ stackp -= 2; goto fail; } d = *--stackp; p = *--stackp; if (d >= string1 && d <= end1) dend = end_match_1; } else break; /* Matching at this starting point really fails! */ } return -1; /* Failure to match */}static intbcmp_translate (s1, s2, len, translate) unsigned char *s1, *s2; register1 int len; unsigned char *translate;{ register1 unsigned char *p1 = s1, *p2 = s2; while (len) { if (translate [*p1++] != translate [*p2++]) return 1; len--; } return 0;}/* Entry points compatible with bsd4.2 regex library */#ifndef emacsstatic struct re_pattern_buffer re_comp_buf;char *re_comp (s) char *s;{ if (!s) { if (!re_comp_buf.buffer) return "No previous regular expression"; return 0; } if (!re_comp_buf.buffer) { if (!(re_comp_buf.buffer = (char *) malloc (200))) return "Memory exhausted"; re_comp_buf.allocated = 200; if (!(re_comp_buf.fastmap = (char *) malloc (1 << BYTEWIDTH))) return "Memory exhausted"; } return re_compile_pattern (s, strlen (s), &re_comp_buf);}intre_exec (s) char *s;{ int len = strlen (s); return 0 <= re_search (&re_comp_buf, s, len, 0, len, 0);}#endif /* emacs */#ifdef test#include <stdio.h>/* Indexed by a character, gives the upper case equivalent of the character */static char upcase[0400] = { 000, 001, 002, 003, 004, 005, 006, 007, 010, 011, 012, 013, 014, 015, 016, 017, 020, 021, 022, 023, 024, 025, 026, 027, 030, 031, 032, 033, 034, 035, 036, 037, 040, 041, 042, 043, 044, 045, 046, 047, 050, 051, 052, 053, 054, 055, 056, 057, 060, 061, 062, 063, 064, 065, 066, 067, 070, 071, 072, 073, 074, 075, 076, 077, 0100, 0101, 0102, 0103, 0104, 0105, 0106, 0107, 0110, 0111, 0112, 0113, 0114, 0115, 0116, 0117, 0120, 0121, 0122, 0123, 0124, 0125, 0126, 0127, 0130, 0131, 0132, 0133, 0134, 0135, 0136, 0137, 0140, 0101, 0102, 0103, 0104, 0105, 0106, 0107, 0110, 0111, 0112, 0113, 0114, 0115, 0116, 0117, 0120, 0121, 0122, 0123, 0124, 0125, 0126, 0127, 0130, 0131, 0132, 0173, 0174, 0175, 0176, 0177, 0200, 0201, 0202, 0203, 0204, 0205, 0206, 0207, 0210, 0211, 0212, 0213, 0214, 0215, 0216, 0217, 0220, 0221, 0222, 0223, 0224, 0225, 0226, 0227, 0230, 0231, 0232, 0233, 0234, 0235, 0236, 0237, 0240, 0241, 0242, 0243, 0244, 0245, 0246, 0247, 0250, 0251, 0252, 0253, 0254, 0255, 0256, 0257, 0260, 0261, 0262, 0263, 0264, 0265, 0266, 0267, 0270, 0271, 0272, 0273, 0274, 0275, 0276, 0277, 0300, 0301, 0302, 0303, 0304, 0305, 0306, 0307, 0310, 0311, 0312, 0313, 0314, 0315, 0316, 0317, 0320, 0321, 0322, 0323, 0324, 0325, 0326, 0327, 0330, 0331, 0332, 0333, 0334, 0335, 0336, 0337, 0340, 0341, 0342, 0343, 0344, 0345, 0346, 0347, 0350, 0351, 0352, 0353, 0354, 0355, 0356, 0357, 0360, 0361, 0362, 0363, 0364, 0365, 0366, 0367, 0370, 0371, 0372, 0373, 0374, 0375, 0376, 0377 };/*main (argc, argv) int argc; char **argv;{ char pat[80]; struct re_pattern_buffer buf; int i; char c; char fastmap[(1 << BYTEWIDTH)]; /* Allow a command argument to specify the style of syntax. */ if (argc > 1) obscure_syntax = atoi (argv[1]); buf.allocated = 40; buf.buffer = (char *) malloc ((int) buf.allocated); buf.fastmap = fastmap; buf.translate = upcase; while (1) { gets (pat); if (*pat) { re_compile_pattern (pat, strlen(pat), &buf); for (i = 0; i < buf.used; i++) printchar (buf.buffer[i]); putchar ('\n'); printf ("%d allocated, %d used.\n", buf.allocated, buf.used); re_compile_fastmap (&buf); printf ("Allowed by fastmap: "); for (i = 0; i < (1 << BYTEWIDTH); i++) if (fastmap[i]) printchar (i); putchar ('\n'); } gets (pat); /* Now read the string to match against */ i = re_match (&buf, pat, strlen (pat), 0, 0); printf ("Match value %d.\n", i); }}*/#ifdef NOTDEFprint_buf (bufp) struct re_pattern_buffer *bufp;{ int i; printf ("buf is :\n----------------\n"); for (i = 0; i < bufp->used; i++) printchar (bufp->buffer[i]); printf ("\n%d allocated, %d used.\n", bufp->allocated, bufp->used); printf ("Allowed by fastmap: "); for (i = 0; i < (1 << BYTEWIDTH); i++) if
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:gawk ƒ:regex.c
+++++ Continued from previous card +++++
(bufp->fastmap[i]) printchar (i); printf ("\nAllowed by translate: "); if (bufp->translate) for (i = 0; i < (1 << BYTEWIDTH); i++) if (bufp->translate[i]) printchar (i); printf ("\nfastmap is%s accurate\n", bufp->fastmap_accurate ? "" : "n't"); printf ("can %s be null\n----------", bufp->can_be_null ? "" : "not");}#endifprintchar (c) char c;{ if (c < 041 || c >= 0177) { putchar ('\\'); putchar (((c >> 6) & 3) + '0'); putchar (((c >> 3) & 7) + '0'); putchar ((c & 7) + '0'); } else putchar (c);}error (string) char *string;{ puts (string); exit (1);}#endif test :MPW:MPW Tools:Tools with Source:gawk ƒ:regex.h
/* Definitions for data structures callers pass the regex library. Copyright (C) 1985 Free Software Foundation, Inc. NO WARRANTY BECAUSE THIS PROGRAM IS LICENSED FREE OF CHARGE, WE PROVIDE ABSOLUTELYNO WARRANTY, TO THE EXTENT PERMITTED BY APPLICABLE STATE LAW. EXCEPTWHEN OTHERWISE STATED IN WRITING, FREE SOFTWARE FOUNDATION, INC,RICHARD M. STALLMAN AND/OR OTHER PARTIES PROVIDE THIS PROGRAM "AS IS"WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING,BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY ANDFITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITYAND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVEDEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR ORCORRECTION. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW WILL RICHARD M.STALLMAN, THE FREE SOFTWARE FOUNDATION, INC., AND/OR ANY OTHER PARTYWHO MAY MODIFY AND REDISTRIBUTE THIS PROGRAM AS PERMITTED BELOW, BELIABLE TO YOU FOR DAMAGES, INCLUDING ANY LOST PROFITS, LOST MONIES, OROTHER SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THEUSE OR INABILITY TO USE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA ORDATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY THIRD PARTIES ORA FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS) THISPROGRAM, EVEN IF YOU HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCHDAMAGES, OR FOR ANY CLAIM BY ANY OTHER PARTY. GENERAL PUBLIC LICENSE TO COPY 1. You may copy and distribute verbatim copies of this source fileas you receive it, in any medium, provided that you conspicuously andappropriately publish on each copy a valid copyright notice "Copyright(C) 1985 Free Software Foundation, Inc."; and include following thecopyright notice a verbatim copy of the above disclaimer of warrantyand of this License. You may charge a distribution fee for thephysical act of transferring a copy. 2. You may modify your copy or copies of this source file orany portion of it, and copy and distribute such modifications underthe terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains or is a derivative of this program or any part thereof, to be licensed at no charge to all third parties on terms identical to those contained in this License Agreement (except that you may choose to grant more extensive warranty protection to some or all third parties, at your option). c) You may charge a distribution fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee.Mere aggregation of another unrelated program with this program (or itsderivative) on a volume of a storage or distribution medium does not bringthe other program under the scope of these terms. 3. You may copy and distribute this program (or a portion or derivativeof it, under Paragraph 2) in object code or executable form under the termsof Paragraphs 1 and 2 above provided that you also do one of the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal shipping charge) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.)For an executable file, complete source code means all the source code forall modules it contains; but, as a special exception, it need not includesource code for modules which are standard libraries that accompany theoperating system on which the executable file runs. 4. You may not copy, sublicense, distribute or transfer this programexcept as expressly provided under this License Agreement. Any attemptotherwise to copy, sublicense, distribute or transfer this program is void andyour rights to use the program under this License agreement shall beautomatically terminated. However, parties who have received computersoftware programs from you with this License Agreement will not havetheir licenses terminated so long as such parties remain in full compliance. 5. If you wish to incorporate parts of this program into other freeprograms whose distribution conditions are different, write to the FreeSoftware Foundation at 675 Mass Ave, Cambridge, MA 02139. We have not yetworked out a simple rule that can be stated here, but we will often permitthis. We will be guided by the two goals of preserving the free status ofall derivatives of our free software and of promoting the sharing and reuse ofsoftware.In other words, you are welcome to use, share and improve this program.You are forbidden to forbid anyone else to use, share and improvewhat you give them. Help stamp out software-hoarding! *//* Define number of parens for which we record the beginnings and ends. This affects how much space the `struct re_registers' type takes up. */#ifndef RE_NREGS#define RE_NREGS 10#endif/* These bits are used in the obscure_syntax variable to choose among alternative regexp syntaxes. *//* 1 means plain parentheses serve as grouping, and backslash parentheses are needed for literal searching. 0 means backslash-parentheses are grouping, and plain parentheses are for literal searching. */#define RE_NO_BK_PARENS 1/* 1 means plain | serves as the "or"-operator, and \| is a literal. 0 means \| serves as the "or"-operator, and | is a literal. */#define RE_NO_BK_VBAR 2/* 0 means plain + or ? serves as an operator, and \+, \? are literals. 1 means \+, \? are operators and plain +, ? are literals. */#define RE_BK_PLUS_QM 4/* 1 means | binds tighter than ^ or $. 0 means the contrary. */#define RE_TIGHT_VBAR 8/* 1 means treat \n as an _OR operator 0 means treat it as a normal character */#define RE_NEWLINE_OR 16/* 0 means that a special characters (such as *, ^, and $) always have their special meaning regardless of the surrounding context. 1 means that special characters may act as normal characters in some contexts. Specifically, this applies to: ^ - only special at the beginning, or after ( or | $ - only special at the end, or before ) or | *, +, ? - only special when not after the beginning, (, or | */#define RE_CONTEXT_INDEP_OPS 32/* Now define combinations of bits for the standard possibilities. */#define RE_SYNTAX_EGREP \ (RE_NO_BK_PARENS | RE_NO_BK_VBAR | RE_NEWLINE_OR | RE_CONTEXT_INDEP_OPS)#define RE_SYNTAX_GREP (RE_BK_PLUS_QM | RE_NEWLINE_OR)#define RE_SYNTAX_EMACS 0/* This data structure is used to represent a compiled pattern. */struct re_pattern_buffer { char *buffer; /* Space holding the compiled pattern commands. */ long allocated; /* Size of space that buffer points to */ long used; /* Length of portion of buffer actually occupied */ char *fastmap; /* Pointer to fastmap, if any, or zero if none. */ /* re_search uses the fastmap, if there is one, to skip quickly over totally implausible characters */ char *translate; /* Translate table to apply to all characters before comparing. Or zero for no translation. The translation is applied to a pattern when it is compiled and to data when it is matched. */ char fastmap_accurate; /* Set to zero when a new pattern is stored, set to one when the fastmap is updated from it. */ char can_be_null; /* Set to one by compiling fastmap if this pattern might match the null string. It does not necessarily match the null string in that case, but if this is zero, it cannot. 2 as value means can match null string but at end of range or before a character listed in the fastmap. */ };/* Structure to store "register" contents data in. Pass the address of such a structure as an argument to re_match, etc., if you want this information back. start[i] and end[i] record the string matched by \( ... \) grouping i, for i from 1 to RE_NREGS - 1. start[0] and end[0] record the entire string matched. */struct re_registers { long start[RE_NREGS]; long end[RE_NREGS]; };/* These are the command codes that appear in compiled regular expressions, one per byte. Some command codes are followed by argument bytes. A command code can specify any interpretation whatever for its arguments. Zero-bytes may appear in the compiled regular expression. */enum regexpcode { unused, exactn, /* followed by one byte giving n, and then by n literal bytes */ begline, /* fails unless at beginning of line */ endline, /* fails unless at end of line */ jump, /* followed by two bytes giving relative address to jump to */ on_failure_jump, /* followed by two bytes giving relative address of place to resume at in case of failure. */ finalize_jump, /* Throw away latest failure point and then jump to address. */ maybe_finalize_jump, /* Like jump but finalize if safe to do so. This is used to jump back to the beginning of a repeat. If the command that follows this jump is clearly incompatible with the one at the beginning of the repeat, such that we can be sure that there is no use backtracking out of repetitions already completed, then we finalize. */ dummy_failure_jump, /* jump, and push a dummy failure point. This failure point will be thrown away if an attempt is made to use it for a failure. A + construct makes this before the first repeat. */ anychar, /* matches any one character */ charset, /* matches any one char belonging to specified set. First following byte is # bitmap bytes. Then come bytes for a bit-map saying which chars are in. Bits in each byte are ordered low-bit-first. A character is in the set if its bit is 1. A character too large to have a bit in the map is automatically not in the set */ charset_not, /* similar but match any character that is NOT one of those specified */ start_memory, /* starts remembering the text that is matched and stores it in a memory register. followed by one byte containing the register number. Register numbers must be in the range 0 through NREGS. */ stop_memory, /* stops remembering the text that is matched and stores it in a memory register. followed by one byte containing the register number. Register numbers must be in the range 0 through NREGS. */ duplicate, /* match a duplicate of something remembered. Followed by one byte containing the index of the memory register. */ before_dot, /* Succeeds if before dot */ at_dot, /* Succeeds if at dot */ after_dot, /* Succeeds if after dot */ begbuf, /* Succeeds if at beginning of buffer */ endbuf, /* Succeeds if at end of buffer */ wordchar, /* Matches any word-constituent character */ notwordchar, /* Matches any char that is not a word-constituent */ wordbeg, /* Succeeds if at word beginning */ wordend, /* Succeeds if at word end */ wordbound, /* Succeeds if at a word boundary */ notwordbound, /* Succeeds if not at a word boundary */ syntaxspec, /* Matches any character whose syntax is specified. followed by a byte which contains a syntax code, Sword or such like */ notsyntaxspec /* Matches any character whose syntax differs from the specified. */ };extern char *re_compile_pattern ();/* Is this really advertised? */extern void re_compile_fastmap ();/* extern long re_search (), re_search_2 (); *//* extern long re_match (), re_match_2 (); *//* 4.2 bsd compatibility (yuck) */extern char *re_comp ();/* extern long re_exec (); */#ifdef SYNTAX_TABLEextern char *re_syntax_table;#endif :MPW:MPW Tools:Tools with Source:gawk ƒ:version.c
#include <stdio.h>#include <string.h>char *version_string = "Gnu Awk (gawk) version 1.03 (I guess)\r\Macintosh MPW version alpha\r\by Z. Fiedorowicz\r\bug reports:zf@osupyr.mast.ohio-state.edu\r";/* 1.02 fixed /= += *= etc to return the new Left Hand Side instead of the Right Hand Side *//* 1.03 Fixed split() to treat strings of space and tab as FS if the split char is ' '. Added -v option to print version number Fixed bug that caused rounding when printing large numbers */ :MPW:MPW Tools:Tools with Source:gnu grep 1.5 ƒ:alloca.c
/* alloca -- (mostly) portable public-domain implementation -- D A Gwyn This implementation of the PWB library alloca() function, which is used to allocate space off the run-time stack so that it is automatically reclaimed upon procedure exit, was inspired by discussions with J. Q. Johnson of Cornell. It should work under any C implementation that uses an actual procedure stack (as opposed to a linked list of frames). There are some preprocessor constants that can be defined when compiling for your specific system, for improved efficiency; however, the defaults should be okay. The general concept of this implementation is to keep track of all alloca()-allocated blocks, and reclaim any that are found to be deeper in the stack than the current invocation. This heuristic does not reclaim storage as soon as it becomes invalid, but it will do so eventually. As a special case, alloca(0) reclaims storage without allocating any. It is a good idea to use alloca(0) in your main control loop, etc. to force garbage collection.*/#ifndef lintstatic char SCCSid[] = "@(#)alloca.c 1.1"; /* for the "what" utility */#endif#ifdef emacs#include "config.h"#ifdef static/* actually, only want this if static is defined as "" -- this is for usg, in which emacs must undefine static in order to make unexec workable */#ifndef STACK_DIRECTIONyoulose-- must know STACK_DIRECTION at compile-time#endif /* STACK_DIRECTION undefined */#endif static#endif emacs#ifdef X3J11typedef void *pointer; /* generic pointer type */#elsetypedef char *pointer; /* generic pointer type */#endif#define NULL 0 /* null pointer constant */extern void free();extern pointer malloc();/* Define STACK_DIRECTION if you know the direction of stack growth for your system; otherwise it will be automatically deduced at run-time. STACK_DIRECTION > 0 => grows toward higher addresses STACK_DIRECTION < 0 => grows toward lower addresses STACK_DIRECTION = 0 => direction of growth unknown*/#ifndef STACK_DIRECTION#define STACK_DIRECTION 0 /* direction unknown */#endif#if STACK_DIRECTION != 0#define STACK_DIR STACK_DIRECTION /* known at compile-time */#else /* STACK_DIRECTION == 0; need run-time code */static int stack_dir; /* 1 or -1 once known */#define STACK_DIR stack_dirstatic voidfind_stack_direction (/* void */){ static char *addr = NULL; /* address of first `dummy', once known */ auto char dummy; /* to get stack address */ if (addr == NULL) { /* initial entry */ addr = &dummy; find_stack_direction (); /* recurse once */ } else /* second entry */ if (&dummy > addr) stack_dir = 1; /* stack grew upward */ else stack_dir = -1; /* stack grew downward */}#endif /* STACK_DIRECTION == 0 *//* An "alloca header" is used to: (a) chain together all alloca()ed blocks; (b) keep track of stack depth. It is very important that sizeof(header) agree with malloc() alignment chunk size. The following default should work okay.*/#ifndef ALIGN_SIZE#define ALIGN_SIZE sizeof(double)#endiftypedef union hdr{ char align[ALIGN_SIZE]; /* to force sizeof(header) */ struct { union hdr *next; /* for chaining headers */ char *deep; /* for stack depth measure */ } h;} header;/* alloca( size ) returns a pointer to at least `size' bytes of storage which will be automatically reclaimed upon exit from the procedure that called alloca(). Originally, this space was supposed to be taken from the current stack frame of the caller, but that method cannot be made to work for some implementations of C, for example under Gould's UTX/32.*/static header *last_alloca_header = NULL; /* -> last alloca header */pointeralloca (size) /* returns pointer to storage */ unsigned size; /* # bytes to allocate */{ auto char probe; /* probes stack depth: */ register char *depth = &probe;#if STACK_DIRECTION == 0 if (STACK_DIR == 0) /* unknown growth direction */ find_stack_direction ();#endif /* Reclaim garbage, defined as all alloca()ed storage that was allocated from deeper in the stack than currently. */ { register header *hp; /* traverses linked list */ for (hp = last_alloca_header; hp != NULL;) if (STACK_DIR > 0 && hp->h.deep > depth || STACK_DIR < 0 && hp->h.deep < depth) { register header *np = hp->h.next; free ((pointer) hp); /* collect garbage */ hp = np; /* -> next header */ } else break; /* rest are not deeper */ last_alloca_header = hp; /* -> last valid storage */ } if (size == 0) return NULL; /* no allocation required */ /* Allocate combined header + user data storage. */ { register pointer new = malloc (sizeof (header) + size); /* address of header */ ((header *)new)->h.next = last_alloca_header; ((header *)new)->h.deep = depth; last_alloca_header = (header *)new; /* User storage begins just after header. */ return (pointer)((char *)new + sizeof(header)); }} :MPW:MPW Tools:Tools with Source:gnu grep 1.5 ƒ:dfa.c
/* dfa.c - determinisitic extended regexp routines Copyright (C) 1988 Free Software Foundation, Inc. Written June, 1988 by Mike Haertel Modified July, 1988 by Arthur David Olson to assist BMG speedups NO WARRANTY BECAUSE THIS PROGRAM IS LICENSED FREE OF CHARGE, WE PROVIDE ABSOLUTELYNO WARRANTY, TO THE EXTENT PERMITTED BY APPLICABLE STATE LAW. EXCEPTWHEN OTHERWISE STATED IN WRITING, FREE SOFTWARE FOUNDATION, INC,RICHARD M. STALLMAN AND/OR OTHER PARTIES PROVIDE THIS PROGRAM "AS IS"WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING,BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY ANDFITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITYAND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVEDEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR ORCORRECTION. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW WILL RICHARD M.STALLMAN, THE FREE SOFTWARE FOUNDATION, INC., AND/OR ANY OTHER PARTYWHO MAY MODIFY AND REDISTRIBUTE THIS PROGRAM AS PERMITTED BELOW, BELIABLE TO YOU FOR DAMAGES, INCLUDING ANY LOST PROFITS, LOST MONIES, OROTHER SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THEUSE OR INABILITY TO USE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA ORDATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY THIRD PARTIES ORA FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS) THISPROGRAM, EVEN IF YOU HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCHDAMAGES, OR FOR ANY CLAIM BY ANY OTHER PARTY. GENERAL PUBLIC LICENSE TO COPY 1. You may copy and distribute verbatim copies of this source fileas you receive it, in any medium, provided that you conspicuously andappropriately publish on each copy a valid copyright notice "Copyright (C) 1988 Free Software Foundation, Inc."; and include following thecopyright notice a verbatim copy of the above disclaimer of warrantyand of this License. You may charge a distribution fee for thephysical act of transferring a copy. 2. You may modify your copy or copies of this source file orany portion of it, and copy and distribute such modifications underthe terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains or is a derivative of this program or any part thereof, to be licensed at no charge to all third parties on terms identical to those contained in this License Agreement (except that you may choose to grant more extensive warranty protection to some or all third parties, at your option). c) You may charge a distribution fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee.Mere aggregation of another unrelated program with this program (or itsderivative) on a volume of a storage or distribution medium does not bringthe other program under the scope of these terms. 3. You may copy and distribute this program or any portion of it incompiled, executable or object code form under the terms of Paragraphs1 and 2 above provided that you do the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal shipping charge) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.)For an executable file, complete source code means all the source code forall modules it contains; but, as a special exception, it need not includesource code for modules which are standard libraries that accompany theoperating system on which the executable file runs. 4. You may not copy, sublicense, distribute or transfer this programexcept as expressly provided under this License Agreement. Any attemptotherwise to copy, sublicense, distribute or transfer this program is void andyour rights to use the program under this License agreement shall beautomatically terminated. However, parties who have received computersoftware programs from you with this License Agreement will not havetheir licenses terminated so long as such parties remain in full compliance. 5. If you wish to incorporate parts of this program into other freeprograms whose distribution conditions are different, write to the FreeSoftware Foundation at 675 Mass Ave, Cambridge, MA 02139. We have not yetworked out a simple rule that can be stated here, but we will often permitthis. We will be guided by the two goals of preserving the free status ofall derivatives our free software and of promoting the sharing and reuse ofsoftware.In other words, you are welcome to use, share and improve this program.You are forbidden to forbid anyone else to use, share and improvewhat you give them. Help stamp out software-hoarding! */ #include <stdio.h>#include <assert.h>#include <ctype.h>#include "dfa.h"#ifdef __STDC__typedef void *ptr_t;#elsetypedef char *ptr_t;#endifstatic void regmust();static ptr_txcalloc(n, s) int n; size_t s;{ ptr_t r = calloc(n, s); if (r) return r; else regerror("Memory exhausted");}static ptr_txmalloc(n) size_t n;{ ptr_t r = malloc(n); assert(n != 0); if (r) return r; else regerror("Memory exhausted");}static ptr_txrealloc(p, n) ptr_t p; size_t n;{ ptr_t r = realloc(p, n); assert(n != 0); if (r) return r; else regerror("Memory exhausted");}#define CALLOC(p, t, n) ((p) = (t *) xcalloc((n), sizeof (t)))#define MALLOC(p, t, n) ((p) = (t *) xmalloc((n) * sizeof (t)))#define REALLOC(p, t, n) ((p) = (t *) xrealloc((ptr_t) (p), (n) * sizeof (t)))/* Reallocate an array of type t if nalloc is too small for index. */#define REALLOC_IF_NECESSARY(p, t, nalloc, index) \ if ((index) >= (nalloc)) \ { \ while ((index) >= (nalloc)) \ (nalloc) *= 2; \ REALLOC(p, t, nalloc); \ } /* Stuff pertaining to charsets. */statictstbit(b, c) int b; _charset c;{ return c[b / INTBITS] & 1 << b % INTBITS;}static voidsetbit(b, c) int b; _charset c;{ c[b / INTBITS] |= 1 << b % INTBITS;}static voidclrbit(b, c) int b; _charset c;{ c[b / INTBITS] &= ~(1 << b % INTBITS);}static voidcopyset(src, dst) const _charset src; _charset dst;{ int i; for (i = 0; i < _CHARSET_INTS; ++i) dst[i] = src[i];}static voidzeroset(s) _charset s;{ int i; for (i = 0; i < _CHARSET_INTS; ++i) s[i] = 0;}static voidnotset(s) _charset s;{ int i; for (i = 0; i < _CHARSET_INTS; ++i) s[i] = ~s[i];}staticequal(s1, s2) const _charset s1; const _charset s2;{ int i; for (i = 0; i < _CHARSET_INTS; ++i) if (s1[i] != s2[i]) return 0; return 1;} /* A pointer to the current regexp is kept here during parsing. */static struct regexp *reg;/* Find the index of charset s in reg->charsets, or allocate a new charset. */staticcharset_index(s) const _charset s;{ int i; for (i = 0; i < reg->cindex; ++i) if (equal(s, reg->charsets[i])) return i; REALLOC_IF_NECESSARY(reg->charsets, _charset, reg->calloc, reg->cindex); ++reg->cindex; copyset(s, reg->charsets[i]); return i;}/* Syntax bits controlling the behavior of the lexical analyzer. */static syntax_bits, syntax_bits_set;/* Flag for case-folding letters into sets. */static case_fold;/* Entry point to set syntax options. */voidregsyntax(bits, fold) int bits; int fold;{ syntax_bits_set = 1; syntax_bits = bits; case_fold = fold;}/* Lexical analyzer. */static const char *lexstart; /* Pointer to beginning of input string. */static const char *lexptr; /* Pointer to next input character. */static lexleft; /* Number of characters remaining. */static caret_allowed; /* True if backward context allows ^ (meaningful only if RE_CONTEXT_INDEP_OPS is turned off). */static closure_allowed; /* True if backward context allows closures (meaningful only if RE_CONTEXT_INDEP_OPS is turned off). *//* Note that characters become unsigned here. */#define FETCH(c, eoferr) \ { \ if (! lexleft) \ if (eoferr) \ regerror(eoferr); \ else \ return _END; \ (c) = (unsigned char) *lexptr++; \ --lexleft; \ }static _tokenlex(){ _token c, c2; int invert; _charset cset; FETCH(c, (char *) 0); switch (c) { case '^': if (! (syntax_bits & RE_CONTEXT_INDEP_OPS) && (!caret_allowed || (syntax_bits & RE_TIGHT_VBAR) && lexptr - 1 != lexstart)) goto normal_char; caret_allowed = 0; return syntax_bits & RE_TIGHT_VBAR ? _ALLBEGLINE : _BEGLINE; case '$': if (syntax_bits & RE_CONTEXT_INDEP_OPS || !lexleft || (! (syntax_bits & RE_TIGHT_VBAR) && ((syntax_bits & RE_NO_BK_PARENS ? lexleft > 0 && *lexptr == ')' : lexleft > 1 && *lexptr == '\\' && lexptr[1] == ')') || (syntax_bits & RE_NO_BK_VBAR ? lexleft > 0 && *lexptr == '|' : lexleft > 1 && *lexptr == '\\' && lexptr[1] == '|')))) return syntax_bits & RE_TIGHT_VBAR ? _ALLENDLINE : _ENDLINE; goto normal_char; case '\\': FETCH(c, "Unfinished \\ quote"); switch (c) { case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': caret_allowed = 0; closure_allowed = 1; return _BACKREF; case '<': caret_allowed = 0; return _BEGWORD; case '>': caret_allowed = 0; return _ENDWORD; case 'b': caret_allowed = 0; return _LIMWORD; case 'B': caret_allowed = 0; return _NOTLIMWORD; case 'w': case 'W': zeroset(cset); for (c2 = 0; c2 < _NOTCHAR; ++c2) if (ISALNUM(c2)) setbit(c2, cset); if (c == 'W') notset(cset); caret_allowed = 0; closure_allowed = 1; return _SET + charset_index(cset); case '?': if (syntax_bits & RE_BK_PLUS_QM) goto qmark; goto normal_char; case '+': if (syntax_bits & RE_BK_PLUS_QM) goto plus; goto normal_char; case '|': if (! (syntax_bits & RE_NO_BK_VBAR)) goto or; goto normal_char; case '(': if (! (syntax_bits & RE_NO_BK_PARENS)) goto lparen; goto normal_char; case ')': if (! (syntax_bits & RE_NO_BK_PARENS)) goto rparen; goto normal_char; default: goto normal_char; } case '?': if (syntax_bits & RE_BK_PLUS_QM) goto normal_char; qmark: if (! (syntax_bits & RE_CONTEXT_INDEP_OPS) && !closure_allowed) goto normal_char; return _QMARK; case '*': if (! (syntax_bits & RE_CONTEXT_INDEP_OPS) && !closure_allowed) goto normal_char; return _STAR; case '+': if (syntax_bits & RE_BK_PLUS_QM) goto normal_char; plus: if (! (syntax_bits & RE_CONTEXT_INDEP_OPS) && !closure_allowed) goto normal_char; return _PLUS; case '|': if (! (syntax_bits & RE_NO_BK_VBAR)) goto normal_char; or: caret_allowed = 1; closure_allowed = 0; return _OR; case '\n': if (! (syntax_bits & RE_NEWLINE_OR)) goto normal_char; goto or; case '(': if (! (syntax_bits & RE_NO_BK_PARENS)) goto normal_char; lparen: caret_allowed = 1; closure_allowed = 0; return _LPAREN; case ')': if (! (syntax_bits & RE_NO_BK_PARENS)) goto normal_char; rparen: caret_allowed = 0; closure_allowed = 1; return _RPAREN; case '.': zeroset(cset); notset(cset); clrbit('\n', cset); caret_allowed = 0; closure_allowed = 1; return _SET + charset_index(cset); case '[': zeroset(cset); FETCH(c, "Unbalanced ["); if (c == '^') { FETCH(c, "Unbalanced ["); invert = 1; } else invert = 0; do { FETCH(c2, "Unbalanced ["); if (c2 == '-') { FETCH(c2, "Unbalanced ["); while (c <= c2) setbit(c++, cset); FETCH(c, "Unbalanced ["); } else { setbit(c, cset); c = c2; } } while (c != ']'); if (invert) notset(cset); caret_allowed = 0; closure_allowed = 1; return _SET + charset_index(cset); default: normal_char: caret_allowed = 0; closure_allowed = 1; if (case_fold && ISALPHA(c)) { zeroset(cset); if (isupper(c)) c = tolower(c); setbit(c, cset); setbit(toupper(c), cset); return _SET + charset_index(cset); } return c; }} /* Recursive descent parser for regular expressions. */static _token tok; /* Lookahead token. */static depth; /* Current depth of a hypothetical stack holding deferred productions. This is used to determine the depth that will be required of the real stack later on in reganalyze(). *//* Add the given token to the parse tree, maintaining the depth count and updating the maximum depth if necessary. */static voidaddtok(t) _token t;{ REALLOC_IF_NECESSARY(reg->tokens, _token, reg->talloc, reg->tindex); reg->tokens[reg->tindex++] = t; switch (t) { case _QMARK: case _STAR: case _PLUS: break; case _CAT: case _OR: --depth; break; default: ++reg->nleaves; case _EMPTY: ++depth; break; } if (depth > reg->depth) reg->depth = depth;}/* The grammar understood by the parser is as follows. start: regexp _ALLBEGLINE regexp regexp _ALLENDLINE _ALLBEGLINE regexp _ALLENDLINE regexp: regexp _OR branch branch branch: branch closure closure closure: closure _QMARK closure _STAR closure _PLUS atom atom: <normal character> _SET _BACKREF _BEGLINE _ENDLINE _BEGWORD _ENDWORD _LIMWORD _NOTLIMWORD <empty> The parser builds a parse tree in postfix form in an array of tokens. */#ifdef __STDC__static void regexp(void);#elsestatic void regexp();#endifstatic voidatom(){ if (tok >= 0 && tok < _NOTCHAR || tok >= _SET || tok == _BACKREF || tok == _BEGLINE || tok == _ENDLINE || tok == _BEGWORD || tok == _ENDWORD || tok == _LIMWORD || tok == _NOTLIMWORD) { addtok(tok); tok = lex(); } else if (tok == _LPAREN) { tok = lex(); regexp(); if (tok != _RPAREN) regerror("Unbalanced ("); tok = lex(); } else addtok(_EMPTY);}static voidclosure(){ atom(); while (tok == _QMARK || tok == _STAR || tok == _PLUS) { addtok(tok); tok = lex(); }}static voidbranch(){ closure(); while (tok != _RPAREN && tok != _OR && tok != _ALLENDLINE && tok >= 0) { closure(); addtok(_CAT); }}static voidregexp(){ branch(); while (tok == _OR) { tok = lex(); branch(); addtok(_OR); }}/* Main entry point for the parser. S is a string to be parsed, len is the length of the string, so s can include NUL characters. R is a pointer to the struct regexp to parse into. */voidregparse(s, len, r) const char *s; size_t len; struct
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:gnu grep 1.5 ƒ:dfa.c
+++++ Continued from previous card +++++
regexp *r;{ reg = r; lexstart = lexptr = s; lexleft = len; caret_allowed = 1; closure_allowed = 0; if (! syntax_bits_set) regerror("No syntax specified"); tok = lex(); depth = r->depth; if (tok == _ALLBEGLINE) { addtok(_BEGLINE); tok = lex(); regexp(); addtok(_CAT); } else regexp(); if (tok == _ALLENDLINE) { addtok(_ENDLINE); addtok(_CAT); tok = lex(); } if (tok != _END) regerror("Unbalanced )"); addtok(_END - r->nregexps); addtok(_CAT); if (r->nregexps) addtok(_OR); ++r->nregexps;} /* Some primitives for operating on sets of positions. *//* Copy one set to another; the destination must be large enough. */static voidcopy(src, dst) const _position_set *src; _position_set *dst;{ int i; for (i = 0; i < src->nelem; ++i) dst->elems[i] = src->elems[i]; dst->nelem = src->nelem;}/* Insert a position in a set. Position sets are maintained in sorted order according to index. If position already exists in the set with the same index then their constraints are logically or'd together. S->elems must point to an array large enough to hold the resulting set. */static voidinsert(p, s) _position p; _position_set *s;{ int i; _position t1, t2; for (i = 0; i < s->nelem && p.index < s->elems[i].index; ++i) ; if (i < s->nelem && p.index == s->elems[i].index) s->elems[i].constraint |= p.constraint; else { t1 = p; ++s->nelem; while (i < s->nelem) { t2 = s->elems[i]; s->elems[i++] = t1; t1 = t2; } }}/* Merge two sets of positions into a third. The result is exactly as if the positions of both sets were inserted into an initially empty set. */static voidmerge(s1, s2, m) _position_set *s1; _position_set *s2; _position_set *m;{ int i = 0, j = 0; m->nelem = 0; while (i < s1->nelem && j < s2->nelem) if (s1->elems[i].index > s2->elems[j].index) m->elems[m->nelem++] = s1->elems[i++]; else if (s1->elems[i].index < s2->elems[j].index) m->elems[m->nelem++] = s2->elems[j++]; else { m->elems[m-= s1->elems[i++]; m->elems[m->nelem++].constraint |= s2->elems[j++].constraint; } while (i < s1->nelem) m->elems[m->nelem++] = s1->elems[i++]; while (j < s2->nelem) m->elems[m->nelem++] = s2->elems[j++];}/* Delete a position from a set. */static voiddelete(p, s) _position p; _position_set *s;{ int i; for (i = 0; i < s->nelem; ++i) if (p.index == s->elems[i].index) break; if (i < s->nelem) for (--s->nelem; i < s->nelem; ++i) s->elems[i] = s->elems[i + 1];} /* Find the index of the state corresponding to the given position set with the given preceding context, or create a new state if there is no such state. Newline and letter tell whether we got here on a newline or letter, respectively. */staticstate_index(r, s, newline, letter) struct regexp *r; _position_set *s; int newline; int letter;{ int hash = 0; int constraint; int i, j; newline = newline ? 1 : 0; letter = letter ? 1 : 0; for (i = 0; i < s->nelem; ++i) hash ^= s->elems[i].index + s->elems[i].constraint; /* Try to find a state that exactly matches the proposed one. */ for (i = 0; i < r->sindex; ++i) { if (hash != r->states[i].hash || s->nelem != r->states[i].elems.nelem || newline != r->states[i].newline || letter != r->states[i].letter) continue; for (j = 0; j < s->nelem; ++j) if (s->elems[j].constraint != r->states[i].elems.elems[j].constraint || s->elems[j].index != r->states[i].elems.elems[j].index) break; if (j == s->nelem) return i; } /* We'll have to create a new state. */ REALLOC_IF_NECESSARY(r->states, _dfa_state, r->salloc, r->sindex); r->states[i].hash = hash; MALLOC(r->states[i].elems.elems, _position, s->nelem); copy(s, &r->states[i].elems); r->states[i].newline = newline; r->states[i].letter = letter; r->states[i].backref = 0; r->states[i].constraint = 0; r->states[i].first_end = 0; for (j = 0; j < s->nelem; ++j) if (r->tokens[s->elems[j].index] < 0) { constraint = s->elems[j].constraint; if (_SUCCEEDS_IN_CONTEXT(constraint, newline, 0, letter, 0) || _SUCCEEDS_IN_CONTEXT(constraint, newline, 0, letter, 1) || _SUCCEEDS_IN_CONTEXT(constraint, newline, 1, letter, 0) || _SUCCEEDS_IN_CONTEXT(constraint, newline, 1, letter, 1)) r->states[i].constraint |= constraint; if (! r->states[i].first_end) r->states[i].first_end = r->tokens[s->elems[j].index]; } else if (r->tokens[s->elems[j].index] == _BACKREF) { r->states[i].constraint = _NO_CONSTRAINT; r->states[i].backref = 1; } ++r->sindex; return i;} /* Find the epsilon closure of a set of positions. If any position of the set contains a symbol that matches the empty string in some context, replace that position with the elements of its follow labeled with an appropriate constraint. Repeat exhaustively until no funny positions are left. S->elems must be large enough to hold the result. */epsclosure(s, r) _position_set *s; struct regexp *r;{ int i, j; int *visited; _position p, old; MALLOC(visited, int, r->tindex); for (i = 0; i < r->tindex; ++i) visited[i] = 0; for (i = 0; i < s->nelem; ++i) if (r->tokens[s->elems[i].index] >= _NOTCHAR && r->tokens[s->elems[i].index] != _BACKREF && r->tokens[s->elems[i].index] < _SET) { old = s->elems[i]; p.constraint = old.constraint; delete(s->elems[i], s); if (visited[old.index]) { --i; continue; } visited[old.index] = 1; switch (r->tokens[old.index]) { case _BEGLINE: p.constraint &= _BEGLINE_CONSTRAINT; break; case _ENDLINE: p.constraint &= _ENDLINE_CONSTRAINT; break; case _BEGWORD: p.constraint &= _BEGWORD_CONSTRAINT; break; case _ENDWORD: p.constraint &= _ENDWORD_CONSTRAINT; break; case _LIMWORD: p.constraint &= _ENDWORD_CONSTRAINT; break; case _NOTLIMWORD: p.constraint &= _NOTLIMWORD_CONSTRAINT; break; } for (j = 0; j < r->follows[old.index].nelem; ++j) { p.index = r->follows[old.index].elems[j].index; insert(p, s); } /* Force rescan to start at the beginning. */ i = -1; } free(visited);} /* Perform bottom-up analysis on the parse tree, computing various functions. Note that at this point, we're pretending constructs like \< are real characters rather than constraints on what can follow them. Nullable: A node is nullable if it is at the root of a regexp that can match the empty string. * _EMPTY leaves are nullable. * No other leaf is nullable. * A _QMARK or _STAR node is nullable. * A _PLUS node is nullable if its argument is nullable. * A _CAT node is nullable if both its arguments are nullable. * An _OR node is nullable if either argument is nullable. Firstpos: The firstpos of a node is the set of positions (nonempty leaves) that could correspond to the first character of a string matching the regexp rooted at the given node. * _EMPTY leaves have empty firstpos. * The firstpos of a nonempty leaf is that leaf itself. * The firstpos of a _QMARK, _STAR, or _PLUS node is the firstpos of its argument. * The firstpos of a _CAT node is the firstpos of the left argument, union the firstpos of the right if the left argument is nullable. * The firstpos of an _OR node is the union of firstpos of each argument. Lastpos: The lastpos of a node is the set of positions that could correspond to the last character of a string matching the regexp at the given node. * _EMPTY leaves have empty lastpos. * The lastpos of a nonempty leaf is that leaf itself. * The lastpos of a _QMARK, _STAR, or _PLUS node is the lastpos of its argument. * The lastpos of a _CAT node is the lastpos of its right argument, union the lastpos of the left if the right argument is nullable. * The lastpos of an _OR node is the union of the lastpos of each argument. Follow: The follow of a position is the set of positions that could correspond to the character following a character matching the node in a string matching the regexp. At this point we consider special symbols that match the empty string in some context to be just normal characters. Later, if we find that a special symbol is in a follow set, we will replace it with the elements of its follow, labeled with an appropriate constraint. * Every node in the firstpos of the argument of a _STAR or _PLUS node is in the follow of every node in the lastpos. * Every node in the firstpos of the second argument of a _CAT node is in the follow of every node in the lastpos of the first argument. Because of the postfix representation of the parse tree, the depth-first analysis is conveniently done by a linear scan with the aid of a stack. Sets are stored as arrays of the elements, obeying a stack-like allocation scheme; the number of elements in each set deeper in the stack can be used to determine the address of a particular set's array. */voidreganalyze(r, searchflag) struct regexp *r; int searchflag;{ int *nullable; /* Nullable stack. */ int *nfirstpos; /* Element count stack for firstpos sets. */ _position *firstpos; /* Array where firstpos elements are stored. */ int *nlastpos; /* Element count stack for lastpos sets. */ _position *lastpos; /* Array where lastpos elements are stored. */ int *nalloc; /* Sizes of arrays allocated to follow sets. */ _position_set tmp; /* Temporary set for merging sets. */ _position_set merged; /* Result of merging sets. */ int wants_newline; /* True if some position wants newline info. */ int *o_nullable; int *o_nfirst, *o_nlast; _position *o_firstpos, *o_lastpos; int i, j; _position *pos; r->searchflag = searchflag; MALLOC(nullable, int, r->depth); o_nullable = nullable; MALLOC(nfirstpos, int, r->depth); o_nfirst = nfirstpos; MALLOC(firstpos, _position, r->nleaves); o_firstpos = firstpos, firstpos += r->nleaves; MALLOC(nlastpos, int, r->depth); o_nlast = nlastpos; MALLOC(lastpos, _position, r->nleaves); o_lastpos = lastpos, lastpos += r->nleaves; MALLOC(nalloc, int, r->tindex); for (i = 0; i < r->tindex; ++i) nalloc[i] = 0; MALLOC(merged.elems, _position, r->nleaves); CALLOC(r->follows, _position_set, r->tindex); for (i = 0; i < r->tindex; ++i) switch (r->tokens[i]) { case _EMPTY: /* The empty set is nullable. */ *nullable++ = 1; /* The firstpos and lastpos of the empty leaf are both empty. */ *nfirstpos++ = *nlastpos++ = 0; break; case _STAR: case _PLUS: /* Every element in the firstpos of the argument is in the follow of every element in the lastpos. */ tmp.nelem = nfirstpos[-1]; tmp.elems = firstpos; pos = lastpos; for (j = 0; j < nlastpos[-1]; ++j) { merge(&tmp, &r->follows[pos[j].index], &merged); REALLOC_IF_NECESSARY(r->follows[pos[j].index].elems, _position, nalloc[pos[j].index], merged.nelem - 1); copy(&merged, &r->follows[pos[j].index]); } case _QMARK: /* A _QMARK or _STAR node is automatically nullable. */ if (r->tokens[i] != _PLUS) nullable[-1] = 1; break; case _CAT: /* Every element in the firstpos of the second argument is in the follow of every element in the lastpos of the first argument. */ tmp.nelem = nfirstpos[-1]; tmp.elems = firstpos; pos = lastpos + nlastpos[-1]; for (j = 0; j < nlastpos[-2]; ++j) { merge(&tmp, &r->follows[pos[j].index], &merged); REALLOC_IF_NECESSARY(r->follows[pos[j].index].elems, _position, nalloc[pos[j].index], merged.nelem - 1); copy(&merged, &r->follows[pos[j].index]); } /* The firstpos of a _CAT node is the firstpos of the first argument, union that of the second argument if the first is nullable. */ if (nullable[-2]) nfirstpos[-2] += nfirstpos[-1]; else firstpos += nfirstpos[-1]; --nfirstpos; /* The lastpos of a _CAT node is the lastpos of the second argument, union that of the first argument if the second is nullable. */ if (nullable[-1]) nlastpos[-2] += nlastpos[-1]; else { pos = lastpos + nlastpos[-2]; for (j = nlastpos[-1] - 1; j >= 0; --j) pos[j] = lastpos[j]; lastpos += nlastpos[-2]; nlastpos[-2] = nlastpos[-1]; } --nlastpos; /* A _CAT node is nullable if both arguments are nullable. */ nullable[-2] = nullable[-1] && nullable[-2]; --nullable; break; case _OR: /* The firstpos is the union of the firstpos of each argument. */ nfirstpos[-2] += nfirstpos[-1]; --nfirstpos; /* The lastpos is the union of the lastpos of each argument. */ nlastpos[-2] += nlastpos[-1]; --nlastpos; /* An _OR node is nullable if either argument is nullable. */ nullable[-2] = nullable[-1] || nullable[-2]; --nullable; break; default: /* Anything else is a nonempty position. (Note that special constructs like \< are treated as nonempty strings here; an "epsilon closure" effectively makes them nullable later. Backreferences have to get a real position so we can detect transitions on them later. But they are nullable. */ *nullable++ = r->tokens[i] == _BACKREF; /* This position is in its own firstpos and lastpos. */ *nfirstpos++ = *nlastpos++ = 1; --firstpos, --lastpos; firstpos->index = lastpos->index = i; firstpos->constraint = lastpos->constraint = _NO_CONSTRAINT; /* Allocate the follow set for this position. */ nalloc[i] = 1; MALLOC(r->follows[i].elems, _position, nalloc[i]); break; } /* For each follow set that is the follow set of a real position, replace it with its epsilon closure. */ for (i = 0; i < r->tindex; ++i) if (r->tokens[i] < _NOTCHAR || r->tokens[i] == _BACKREF || r->tokens[i] >= _SET) { copy(&r->follows[i], &merged); epsclosure(&merged, r); if (r->follows[i].nelem < merged.nelem) REALLOC(r->follows[i].elems, _position, merged.nelem); copy(&merged, &r->follows[i]); } /* Get the epsilon closure of the firstpos of the regexp. The result will be the set of positions of state 0. */ merged.nelem = 0; for (i = 0; i < nfirstpos[-1]; ++i) insert(firstpos[i], &merged); epsclosure(&merged, r); /* Check if any of the positions of state 0 will want newline context. */ wants_newline = 0; for (i = 0; i < merged.nelem; ++i) if (_PREV_NEWLINE_DEPENDENT(merged.elems[i].constraint)) wants_newline = 1; /* Build the initial state. */ r->salloc = 1; r->sindex = 0; MALLOC(r->states, _dfa_state, r->salloc); state_index(r, &merged, wants_newline, 0); free(o_nullable); free(o_nfirst); free(o_firstpos); free(o_nlast); free(o_lastpos); free(nalloc); free(merged.elems);} /* Find, for each character, the transition out of state s of r, and store it in the appropriate slot of trans. We divide the positions of s into groups (positions can appear in more than one group). Each group is labeled with a set of characters that every position in the group matches (taking into account, if necessary, preceding context information of s). For each group, find the union of the its elements' follows. This set is the set of positions of the new state. For each character in the group's label, set the transition on this character to be to a state corresponding to the set's positions, and its associated backward context information, if necessary. If we are building a searching matcher, we include the positions of state 0 in every state. The collection of groups is constructed by building an equivalence-c
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:gnu grep 1.5 ƒ:dfa.c
+++++ Continued from previous card +++++
lass partition of the positions of s. For each position, find the set of characters C that it matches. Eliminate any characters from C that fail on grounds of backward context. Search through the groups, looking for a group whose label L has nonempty intersection with C. If L - C is nonempty, create a new group labeled L - C and having the same positions as the current group, and set L to the intersection of L and C. Insert the position in this group, set C = C - L, and resume scanning. If after comparing with every group there are characters remaining in C, create a new group labeled with the characters of C and insert this position in that group. */voidregstate(s, r, trans) int s; struct regexp *r; int trans[];{ _position_set grps[_NOTCHAR]; /* As many as will ever be needed. */ _charset labels[_NOTCHAR]; /* Labels corresponding to the groups. */ int ngrps = 0; /* Number of groups actually used. */ _position pos; /* Current position being considered. */ _charset matches; /* Set of matching characters. */ int matchesf; /* True if matches is nonempty. */ _charset intersect; /* Intersection with some label set. */ int intersectf; /* True if intersect is nonempty. */ _charset leftovers; /* Stuff in the label that didn't match. */ int leftoversf; /* True if leftovers is nonempty. */ static _charset letters; /* Set of characters considered letters. */ static _charset newline; /* Set of characters that aren't newline. */ _position_set follows; /* Union of the follows of some group. */ _position_set tmp; /* Temporary space for merging sets. */ int state; /* New state. */ int wants_newline; /* New state wants to know newline context. */ int state_newline; /* New state on a newline transition. */ int wants_letter; /* New state wants to know letter context. */ int state_letter; /* New state on a letter transition. */ static initialized; /* Flag for static initialization. */ int i, j, k; /* Initialize the set of letters, if necessary. */ if (! initialized) { initialized = 1; for (i = 0; i < _NOTCHAR; ++i) if (ISALNUM(i)) setbit(i, letters); setbit('\n', newline); } zeroset(matches); for (i = 0; i < r->states[s].elems.nelem; ++i) { pos = r->states[s].elems.elems[i]; if (r->tokens[pos.index] >= 0 && r->tokens[pos.index] < _NOTCHAR) setbit(r->tokens[pos.index], matches); else if (r->tokens[pos.index] >= _SET) copyset(r->charsets[r->tokens[pos.index] - _SET], matches); else continue; /* Some characters may need to be climinated from matches because they fail in the current context. */ if (pos.constraint != 0xff) { if (! _MATCHES_NEWLINE_CONTEXT(pos.constraint, r->states[s].newline, 1)) clrbit('\n', matches); if (! _MATCHES_NEWLINE_CONTEXT(pos.constraint, r->states[s].newline, 0)) for (j = 0; j < _CHARSET_INTS; ++j) matches[j] &= newline[j]; if (! _MATCHES_LETTER_CONTEXT(pos.constraint, r->states[s].letter, 1)) for (j = 0; j < _CHARSET_INTS; ++j) matches[j] &= ~letters[j]; if (! _MATCHES_LETTER_CONTEXT(pos.constraint, r->states[s].letter, 0)) for (j = 0; j < _CHARSET_INTS; ++j) matches[j] &= letters[j]; /* If there are no characters left, there's no point in going on. */ for (j = 0; j < _CHARSET_INTS && !matches[j]; ++j) ; if (j == _CHARSET_INTS) continue; } for (j = 0; j < ngrps; ++j) { /* If matches contains a single character only, and the current group's label doesn't contain that character, go on to the next group. */ if (r->tokens[pos.index] >= 0 && r->tokens[pos.index] < _NOTCHAR && !tstbit(r->tokens[pos.index], labels[j])) continue; /* Check if this group's label has a nonempty intersection with matches. */ intersectf = 0; for (k = 0; k < _CHARSET_INTS; ++k) (intersect[k] = matches[k] & labels[j][k]) ? intersectf = 1 : 0; if (! intersectf) continue; /* It does; now find the set differences both ways. */ leftoversf = matchesf = 0; for (k = 0; k < _CHARSET_INTS; ++k) { /* Even an optimizing compiler can't know this for sure. */ int match = matches[k], label = labels[j][k]; (leftovers[k] = ~match & label) ? leftoversf = 1 : 0; (matches[k] = match & ~label) ? matchesf = 1 : 0; } /* If there were leftovers, create a new group labeled with them. */ if (leftoversf) { copyset(leftovers, labels[ngrps]); copyset(intersect, labels[j]); MALLOC(grps[ngrps].elems, _position, r->nleaves); copy(&grps[j], &grps[ngrps]); ++ngrps; } /* Put the position in the current group. Note that there is no reason to call insert() here. */ grps[j].elems[grps[j].nelem++] = pos; /* If every character matching the current position has been accounted for, we're done. */ if (! matchesf) break; } /* If we've passed the last group, and there are still characters unaccounted for, then we'll have to create a new group. */ if (j == ngrps) { copyset(matches, labels[ngrps]); zeroset(matches); MALLOC(grps[ngrps].elems, _position, r->nleaves); grps[ngrps].nelem = 1; grps[ngrps].elems[0] = pos; ++ngrps; } } MALLOC(follows.elems, _position, r->nleaves); MALLOC(tmp.elems, _position, r->nleaves); /* If we are a searching matcher, the default transition is to a state containing the positions of state 0, otherwise the default transition is to fail miserably. */ if (r->searchflag) { wants_newline = 0; wants_letter = 0; for (i = 0; i < r->states[0].elems.nelem; ++i) { if (_PREV_NEWLINE_DEPENDENT(r->states[0].elems.elems[i].constraint)) wants_newline = 1; if (_PREV_LETTER_DEPENDENT(r->states[0].elems.elems[i].constraint)) wants_letter = 1; } copy(&r->states[0].elems, &follows); state = state_index(r, &follows, 0, 0); if (wants_newline) state_newline = state_index(r, &follows, 1, 0); else state_newline = state; if (wants_letter) state_letter = state_index(r, &follows, 0, 1); else state_letter = state; for (i = 0; i < _NOTCHAR; ++i) if (i == '\n') trans[i] = state_newline; else if (ISALNUM(i)) trans[i] = state_letter; else trans[i] = state; } else for (i = 0; i < _NOTCHAR; ++i) trans[i] = -1; for (i = 0; i < ngrps; ++i) { follows.nelem = 0; /* Find the union of the follows of the positions of the group. This is a hideously inefficient loop. Fix it someday. */ for (j = 0; j < grps[i].nelem; ++j) for (k = 0; k < r->follows[grps[i].elems[j].index].nelem; ++k) insert(r->follows[grps[i].elems[j].index].elems[k], &follows); /* If we are building a searching matcher, throw in the positions of state 0 as well. */ if (r->searchflag) for (j = 0; j < r->states[0].elems.nelem; ++j) insert(r->states[0].elems.elems[j], &follows); /* Find out if the new state will want any context information. */ wants_newline = 0; if (tstbit('\n', labels[i])) for (j = 0; j < follows.nelem; ++j) if (_PREV_NEWLINE_DEPENDENT(follows.elems[j].constraint)) wants_newline = 1; wants_letter = 0; for (j = 0; j < _CHARSET_INTS; ++j) if (labels[i][j] & letters[j]) break; if (j < _CHARSET_INTS) for (j = 0; j < follows.nelem; ++j) if (_PREV_LETTER_DEPENDENT(follows.elems[j].constraint)) wants_letter = 1; /* Find the state(s) corresponding to the union of the follows. */ state = state_index(r, &follows, 0, 0); if (wants_newline) state_newline = state_index(r, &follows, 1, 0); else state_newline = state; if (wants_letter) state_letter = state_index(r, &follows, 0, 1); else state_letter = state; /* Set the transitions for each character in the current label. */ for (j = 0; j < _CHARSET_INTS; ++j) for (k = 0; k < INTBITS; ++k) if (labels[i][j] & 1 << k) { int c = j * INTBITS + k; if (c == '\n') trans[c] = state_newline; else if (ISALNUM(c)) trans[c] = state_letter; else if (c < _NOTCHAR) trans[c] = state; } } for (i = 0; i < ngrps; ++i) free(grps[i].elems); free(follows.elems); free(tmp.elems);} /* Some routines for manipulating a compiled regexp's transition tables. Each state may or may not have a transition table; if it does, and it is a non-accepting state, then r->trans[state] points to its table. If it is an accepting state then r->fails[state] points to its table. If it has no table at all, then r->trans[state] is NULL. TODO: Improve this comment, get rid of the unnecessary redundancy. */static voidbuild_state(s, r) int s; struct regexp *r;{ int *trans; /* The new transition table. */ int i; /* Set an upper limit on the number of transition tables that will ever exist at once. 1024 is arbitrary. The idea is that the frequently used transition tables will be quickly rebuilt, whereas the ones that were only needed once or twice will be cleared away. */ if (r->trcount >= 1024) { for (i = 0; i < r->tralloc; ++i) if (r->trans[i]) { free((ptr_t) r->trans[i]); r->trans[i] = NULL; } else if (r->fails[i]) { free((ptr_t) r->fails[i]); r->fails[i] = NULL; } r->trcount = 0; } ++r->trcount; /* Set up the success bits for this state. */ r->success[s] = 0; if (ACCEPTS_IN_CONTEXT(r->states[s].newline, 1, r->states[s].letter, 0, s, *r)) r->success[s] |= 4; if (ACCEPTS_IN_CONTEXT(r->states[s].newline, 0, r->states[s].letter, 1, s, *r)) r->success[s] |= 2; if (ACCEPTS_IN_CONTEXT(r->states[s].newline, 0, r->states[s].letter, 0, s, *r)) r->success[s] |= 1; MALLOC(trans, int, _NOTCHAR); regstate(s, r, trans); /* Now go through the new transition table, and make sure that the trans and fail arrays are allocated large enough to hold a pointer for the largest state mentioned in the table. */ for (i = 0; i < _NOTCHAR; ++i) if (trans[i] >= r->tralloc) { int oldalloc = r->tralloc; while (trans[i] >= r->tralloc) r->tralloc *= 2; REALLOC(r->realtrans, int *, r->tralloc + 1); r->trans = r->realtrans + 1; REALLOC(r->fails, int *, r->tralloc); REALLOC(r->success, int, r->tralloc); REALLOC(r->newlines, int, r->tralloc); while (oldalloc < r->tralloc) { r->trans[oldalloc] = NULL; r->fails[oldalloc++] = NULL; } } /* Keep the newline transition in a special place so we can use it as a sentinel. */ r->newlines[s] = trans['\n']; trans['\n'] = -1; if (ACCEPTING(s, *r)) r->fails[s] = trans; else r->trans[s] = trans;}static voidbuild_state_zero(r) struct regexp *r;{ r->tralloc = 1; r->trcount = 0; CALLOC(r->realtrans, int *, r->tralloc + 1); r->trans = r->realtrans + 1; CALLOC(r->fails, int *, r->tralloc); MALLOC(r->success, int, r->tralloc); MALLOC(r->newlines, int, r->tralloc); build_state(0, r);} /* Search through a buffer looking for a match to the given struct regexp. Find the first occurrence of a string matching the regexp in the buffer, and the shortest possible version thereof. Return a pointer to the first character after the match, or NULL if none is found. Begin points to the beginning of the buffer, and end points to the first character after its end. We store a newline in *end to act as a sentinel, so end had better point somewhere valid. Newline is a flag indicating whether to allow newlines to be in the matching string. If count is non- NULL it points to a place we're supposed to increment every time we see a newline. Finally, if backref is non-NULL it points to a place where we're supposed to store a 1 if backreferencing happened and the match needs to be verified by a backtracking matcher. Otherwise we store a 0 in *backref. */char *regexecute(r, begin, end, newline, count, backref) struct regexp *r; char *begin; char *end; int newline; int *count; int *backref;{ register s, s1, tmp; /* Current state. */ register unsigned char *p; /* Current input character. */ register **trans, *t; /* Copy of r->trans so it can be optimized into a register. */ static sbit[_NOTCHAR]; /* Table for anding with r->success. */ static sbit_init; if (! sbit_init) { int i; sbit_init = 1; for (i = 0; i < _NOTCHAR; ++i) if (i == '\n') sbit[i] = 4; else if (ISALNUM(i)) sbit[i] = 2; else sbit[i] = 1; } if (! r->tralloc) build_state_zero(r); s = 0; p = (unsigned char *) begin; trans = r->trans; *end = '\n'; for (;;) { /* The dreaded inner loop. */ if (t = trans[s]) do { s1 = t[*p++]; if (! (t = trans[s1])) goto last_was_s; s = t[*p++]; } while (t = trans[s]); goto last_was_s1; last_was_s: tmp = s, s = s1, s1 = tmp; last_was_s1: if (s >= 0 && p <= (unsigned char *) end && r->fails[s]) { if (r->success[s] & sbit[*p]) { if (backref) if (r->states[s].backref) *backref = 1; else *backref = 0; return (char *) p; } s1 = s; s = r->fails[s][*p++]; continue; } /* If the previous character was a newline, count it. */ if (count && (char *) p <= end && p[-1] == '\n') ++*count; /* Check if we've run off the end of the buffer. */ if ((char *) p >= end) return NULL; if (s >= 0) { build_state(s, r); trans = r->trans; continue; } if (p[-1] == '\n' && newline) { s = r->newlines[s1]; continue; } s = 0; }} /* Initialize the components of a regexp that the other routines don't initialize for themselves. */voidreginit(r) struct regexp *r;{ r->calloc = 1; MALLOC(r->charsets, _charset, r->calloc); r->cindex = 0; r->talloc = 1;C(r->tokens, _token, r->talloc); r->tindex = r->depth = r->nleaves = r->nregexps = 0; r->searchflag = 0; r->tralloc = 0;}/* Parse and analyze a single string of the given length. */voidregcompile(s, len, r, searchflag) const char *s; size_t len; struct regexp *r; int searchflag;{ if (case_fold) /* dummy folding in service of regmust() */ { char *copy; int i; copy = malloc(len); if (!copy) regerror("out of memory"); /* This is a complete kludge and could potentially break \<letter> escapes . . . */ case_fold = 0; for (i = 0; i < len; ++i) if (ISUPPER(s[i])) copy[i] = tolower(s[i]); else copy[i] = s[i]; reginit(r); r->mustn = 0; r->must[0] = '\0'; regparse(copy, len, r); free(copy); regmust(r); reganalyze(r, searchflag); case_fold = 1; reginit(r); regparse(s, len, r); reganalyze(r, searchflag); } else { reginit(r); regparse(s, len, r); regmust(r); reganalyze(r, searchflag); }}/* Free the storage held by the components of a regexp. */voidregfree(r) struct regexp *r;{ int i; free((ptr_t) r->charsets); free((ptr_t) r->tokens); for (i = 0; i < r->sindex; ++i) free((ptr_t) r->states[i].elems.elems); free((ptr_t) r->states); for (i = 0; i < r->tindex; ++i) if (r->follows[i].elems) free((ptr_t) r->follows[i].elems); free((ptr_t) r->follows); for (i = 0; i < r->tralloc; ++i) if (r->trans[i]) free((ptr_t) r->trans[i]); else if (r->fails[i]) free((ptr_t) r->fails[i]); free((ptr_t) r->realtrans); free((ptr_t) r->fails); free((ptr_t) r->newlines);}/*
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:gnu grep 1.5 ƒ:dfa.c
+++++ Continued from previous card +++++
Having found the postfix representation of the regular expression,try to find a long sequence of characters that must appear in any linecontaining the r.e.Finding a "longest" sequence is beyond the scope here;we take an easy way out and hope for the best.(Take "(ab|a)b"--please.)We do a bottom-up calculation of sequences of characters that must appearin matches of r.e.'s represented by trees rooted at the nodes of the postfixrepresentation: sequences that must appear at the left of the match ("left") sequences that must appear at the right of the match ("right") lists of sequences that must appear somewhere in the match ("in") sequences that must constitute the match ("is")When we get to the root of the tree, we use one of the longest of itscalculated "in" sequences as our answer. The sequence we find is returned inr->must (where "r" is the single argument passed to "regmust");the length of the sequence is returned in r->mustn.The sequences calculated for the various types of node (in pseudo ANSI c)are shown below. "p" is the operand of unary operators (and the left-handoperand of binary operators); "q" is the right-hand operand of binary operators."ZERO" means "a zero-length sequence" below.Type left right is in---- ---- ----- -- --char c # c # c # c # cSET ZERO ZERO ZERO ZEROSTAR ZERO ZERO ZERO ZEROQMARK ZERO ZERO ZERO ZEROPLUS p->left p->right ZERO p->inCAT (p->is==ZERO)? (q->is==ZERO)? (p->is!=ZERO && p->in plus p->left : q->right : q->is!=ZERO) ? q->in plus p->is##q->left p->right##q->is p->is##q->is : p->right##q->left ZEROOR longest common longest common (do p->is and substrings common to leading trailing q->is have same p->in and q->in (sub)sequence (sub)sequence length and of p->left of p->right content) ? and q->left and q->right p->is : NULL If there's anything else we recognize in the tree, all four sequences get setto zero-length sequences. If there's something we don't recognize in the tree,we just return a zero-length sequence.Break ties in favor of infrequent letters (choosing 'zzz' in preference to'aaa')?And. . .is it here or someplace that we might ponder "optimizations" such as egrep 'psi|epsilon' -> egrep 'psi' egrep 'pepsi|epsilon' -> egrep 'epsi' (Yes, we now find "epsi" as a "string that must occur", but we might also simplify the *entire* r.e. being sought) grep '[c]' -> grep 'c' grep '(ab|a)b' -> grep 'ab' grep 'ab*' -> grep 'a' grep 'a*b' -> grep 'b'There are several issues: Is optimization easy (enough)? Does optimization actually accomplish anything, or is the automaton you get from "psi|epsilon" (for example) the same as the one you get from "psi" (for example)? Are optimizable r.e.'s likely to be used in real-life situations (something like 'ab*' is probably unlikely; something like is 'psi|epsilon' is likelier)?*/static char *icatalloc(old, new)char * old;char * new;{ register char * result; register int oldsize, newsize; newsize = (new == NULL) ? 0 : strlen(new); if (old == NULL) oldsize = 0; else if (newsize == 0) return old; else oldsize = strlen(old); if (old == NULL) result = (char *) malloc(newsize + 1); else result = (char *) realloc((void *) old, oldsize + newsize + 1); if (result != NULL && new != NULL) (void) strcpy(result + oldsize, new); return result;}static char *icpyalloc(string)const char * string;{ return icatalloc((char *) NULL, string);}static char *istrstr(lookin, lookfor)char * lookin;register char * lookfor;{ register char * cp; register int len; len = strlen(lookfor); for (cp = lookin; *cp != '\0'; ++cp) if (strncmp(cp, lookfor, len) == 0) return cp; return NULL;}static voidifree(cp)char * cp;{ if (cp != NULL) free(cp);}static voidfreelist(cpp)register char ** cpp;{ register int i; if (cpp == NULL) return; for (i = 0; cpp[i] != NULL; ++i) { free(cpp[i]); cpp[i] = NULL; }}static char **enlist(cpp, new, len)register char ** cpp;register char * new;{ register int i, j; if (cpp == NULL) return NULL; if ((new = icpyalloc(new)) == NULL) { freelist(cpp); return NULL; } new[len] = '\0'; /* ** Is there already something in the list that's new (or longer)? */ for (i = 0; cpp[i] != NULL; ++i) if (istrstr(cpp[i], new) != NULL) { free(new); return cpp; } /* ** Eliminate any obsoleted strings. */ j = 0; while (cpp[j] != NULL) if (istrstr(new, cpp[j]) == NULL) ++j; else { free(cpp[j]); if (--i == j) break; cpp[j] = cpp[i]; } /* ** Add the new string. */ cpp = (char **) realloc((char *) cpp, (i + 2) * sizeof *cpp); if (cpp == NULL) return NULL; cpp[i] = new; cpp[i + 1] = NULL; return cpp;}/*** Given pointers to two strings,** return a pointer to an allocated list of their distinct common substrings.** Return NULL if something seems wild.*/static char **comsubs(left, right)char * left;char * right;{ register char ** cpp; register char * lcp; register char * rcp; register int i, len; if (left == NULL || right == NULL) return NULL; cpp = (char **) malloc(sizeof *cpp); if (cpp == NULL) return NULL; cpp[0] = NULL; for (lcp = left; *lcp != '\0'; ++lcp) { len = 0; rcp = strchr(right, *lcp); while (rcp != NULL) { for (i = 1; lcp[i] != '\0' && lcp[i] == rcp[i]; ++i) ; if (i > len) len = i; rcp = strchr(rcp + 1, *lcp); } if (len == 0) continue; if ((cpp = enlist(cpp, lcp, len)) == NULL) break; } return cpp;}static char **addlists(old, new)char ** old;char ** new;{ register int i; if (old == NULL || new == NULL) return NULL; for (i = 0; new[i] != NULL; ++i) { old = enlist(old, new[i], strlen(new[i])); if (old == NULL) break; } return old;}/*** Given two lists of substrings,** return a new list giving substrings common to both.*/static char **inboth(left, right)char ** left;char ** right;{ register char ** both; register char ** temp; register int lnum, rnum; if (left == NULL || right == NULL) return NULL; both = (char **) malloc(sizeof *both); if (both == NULL) return NULL; both[0] = NULL; for (lnum = 0; left[lnum] != NULL; ++lnum) { for (rnum = 0; right[rnum] != NULL; ++rnum) { temp = comsubs(left[lnum], right[rnum]); if (temp == NULL) { freelist(both); return NULL; } both = addlists(both, temp); freelist(temp); if (both == NULL) return NULL; } } return both;}typedef struct { char ** in; char * left; char * right; char * is;} must;static voidresetmust(mp)register must * mp;{ mp->left[0] = mp->right[0] = mp->is[0] = '\0'; freelist(mp->in);}static voidregmust(r)register struct regexp * r;{ register must * musts; register must * mp; register char * result; register int ri; register int i; register _token t; static must must0; reg->mustn = 0; reg->must[0] = '\0'; musts = (must *) malloc((reg->tindex + 1) * sizeof *musts); if (musts == NULL) return; mp = musts; for (i = 0; i <= reg->tindex; ++i) mp[i] = must0; for (i = 0; i <= reg->tindex; ++i) { mp[i].in = (char **) malloc(sizeof *mp[i].in); mp[i].left = malloc(2); mp[i].right = malloc(2); mp[i].is = malloc(2); if (mp[i].in == NULL || mp[i].left == NULL || mp[i].right == NULL || mp[i].is == NULL) goto done; mp[i].left[0] = mp[i].right[0] = mp[i].is[0] = '\0'; mp[i].in[0] = NULL; } result = ""; for (ri = 0; ri < reg->tindex; ++ri) { switch (t = reg->tokens[ri]) { case _ALLBEGLINE: case _ALLENDLINE: case _LPAREN: case _RPAREN: goto done; /* "cannot happen" */ case _EMPTY: case _BEGLINE: case _ENDLINE: case _BEGWORD: case _ENDWORD: case _LIMWORD: case _NOTLIMWORD: case _BACKREF: resetmust(mp); break; case _STAR: case _QMARK: if (mp <= musts) goto done; /* "cannot happen" */ --mp; resetmust(mp); break; case _OR: if (mp < &musts[2]) goto done; /* "cannot happen" */ { register char ** new; register must * lmp; register must * rmp; register int j, ln, rn, n; rmp = --mp; lmp = --mp; /* Guaranteed to be. Unlikely, but. . . */ if (strcmp(lmp->is, rmp->is) != 0) lmp->is[0] = '\0'; /* Left side--easy */ i = 0; while (lmp->left[i] != '\0' && lmp->left[i] == rmp->left[i]) ++i; lmp->left[i] = '\0'; /* Right side */ ln = strlen(lmp->right); rn = strlen(rmp->right); n = ln; if (n > rn) n = rn; for (i = 0; i < n; ++i) if (lmp->right[ln - i - 1] != rmp->right[rn - i - 1]) break; for (j = 0; j < i; ++j) lmp->right[j] = lmp->right[(ln - i) + j]; lmp->right[j] = '\0'; new = inboth(lmp->in, rmp->in); if (new == NULL) goto done; freelist(lmp->in); free((char *) lmp->in); lmp->in = new; } break; case _PLUS: if (mp <= musts) goto done; /* "cannot happen" */ --mp; mp->is[0] = '\0'; break; case _END: if (mp != &musts[1]) goto done; /* "cannot happen" */ for (i = 0; musts[0].in[i] != NULL; ++i) if (strlen(musts[0].in[i]) > strlen(result)) result = musts[0].in[i]; goto done; case _CAT: if (mp < &musts[2]) goto done; /* "cannot happen" */ { register must * lmp; register must * rmp; rmp = --mp; lmp = --mp; /* ** In. Everything in left, plus everything in ** right, plus catenation of ** left's right and right's left. */ lmp->in = addlists(lmp->in, rmp->in); if (lmp->in == NULL) goto done; if (lmp->right[0] != '\0' && rmp->left[0] != '\0') { register char * tp; tp = icpyalloc(lmp->right); if (tp == NULL) goto done; tp = icatalloc(tp, rmp->left); if (tp == NULL) goto done; lmp->in = enlist(lmp->in, tp, strlen(tp)); free(tp); if (lmp->in == NULL) goto done; } /* Left-hand */ if (lmp->is[0] != '\0') { lmp->left = icatalloc(lmp->left, rmp->left); if (lmp->left == NULL) goto done; } /* Right-hand */ if (rmp->is[0] == '\0') lmp->right[0] = '\0'; lmp->right = icatalloc(lmp->right, rmp->right); if (lmp->right == NULL) goto done; /* Guaranteed to be */ if (lmp->is[0] != '\0' && rmp->is[0] != '\0') { lmp->is = icatalloc(lmp->is, rmp->is); if (lmp->is == NULL) goto done; } } break; default: if (t < _END) { /* "cannot happen" */ goto done; } else if (t == '\0') { /* not on *my* shift */ goto done; } else if (t >= _SET) { /* easy enough */ resetmust(mp); } else { /* plain character */ resetmust(mp); mp->is[0] = mp->left[0] = mp->right[0] = t; mp->is[1] = mp->left[1] = mp->right[1] = '\0'; mp->in = enlist(mp->in, mp->is, 1); if (mp->in == NULL) goto done; } break; } ++mp; }done: (void) strncpy(reg->must, result, MUST_MAX - 1); reg->must[MUST_MAX - 1] = '\0'; reg->mustn = strlen(reg->must); mp = musts; for (i = 0; i <= reg->tindex; ++i) { freelist(mp[i].in); ifree((char *) mp[i].in); ifree(mp[i].left); ifree(mp[i].right); ifree(mp[i].is); } free((char *) mp);} :MPW:MPW Tools:Tools with Source:gnu grep 1.5 ƒ:dfa.h
/* dfa.h - declarations for GNU deterministic regexp compiler Copyright (C) 1988 Free Software Foundation, Inc. Written June, 1988 by Mike Haertel NO WARRANTY BECAUSE THIS PROGRAM IS LICENSED FREE OF CHARGE, WE PROVIDE ABSOLUTELYNO WARRANTY, TO THE EXTENT PERMITTED BY APPLICABLE STATE LAW. EXCEPTWHEN OTHERWISE STATED IN WRITING, FREE SOFTWARE FOUNDATION, INC,RICHARD M. STALLMAN AND/OR OTHER PARTIES PROVIDE THIS PROGRAM "AS IS"WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING,BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY ANDFITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITYAND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVEDEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR ORCORRECTION. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW WILL RICHARD M.STALLMAN, THE FREE SOFTWARE FOUNDATION, INC., AND/OR ANY OTHER PARTYWHO MAY MODIFY AND REDISTRIBUTE THIS PROGRAM AS PERMITTED BELOW, BELIABLE TO YOU FOR DAMAGES, INCLUDING ANY LOST PROFITS, LOST MONIES, OROTHER SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THEUSE OR INABILITY TO USE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA ORDATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY THIRD PARTIES ORA FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS) THISPROGRAM, EVEN IF YOU HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCHDAMAGES, OR FOR ANY CLAIM BY ANY OTHER PARTY. GENERAL PUBLIC LICENSE TO COPY 1. You may copy and distribute verbatim copies of this source fileas you receive it, in any medium, provided that you conspicuously andappropriately publish on each copy a valid copyright notice "Copyright (C) 1988 Free Software Foundation, Inc."; and include following thecopyright notice a verbatim copy of the above disclaimer of warrantyand of this License. You may charge a distribution fee for thephysical act of transferring a copy. 2. You may modify your copy or copies of this source file orany portion of it, and copy and distribute such modifications underthe terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains or is a derivative of this program or any part thereof, to be licensed at no charge to all third parties on terms identical to those contained in this License Agreement (except that you may choose to grant more extensive warranty protection to some or all third parties, at your option). c) You may charge a distribution fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee.Mere aggregation of another unrelated program with this program (or itsderivative) on a volume of a storage or distribution medium does not bringthe other program under the scope of these terms. 3. You may copy and distribute this program or any portion of it incompiled, executable or object code form under the terms of Paragraphs1 and 2 above provided that you do the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal shipping charge) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.)For an executable file, complete source code means all the source code forall modules it contains; but, as a special exception, it need not includesource code for modules which are standard libraries that accompany theoperating system on which the executable file runs. 4. You may not copy, sublicense, distribute or transfer this programexcept as expressly provided under this License Agreement. Any attemptotherwise to copy, sublicense, distribute or transfer this program is void andyour rights to use the program under this License agreement shall beautomatically terminated. However, parties who have received computersoftware programs from you with this License Agreement will not havetheir licenses terminated so long as such parties remain in full compliance. 5. If you wish to incorporate parts of this program into other freeprograms whose distribution conditions are different, write to the FreeSoftware Foundation at 675 Mass Ave, Cambridge, MA 02139. We have not yetworked out a simple rule that can be stated here, but we will often permitthis. We will be guided by the two goals of preserving the free status ofall derivatives our free software and of promoting the sharing and reuse ofsoftware.In other words, you are welcome to use, share and improve this program.You are forbidden to forbid anyone else to use, share and improvewhat you give them. Help stamp out software-hoarding! */ #ifdef USG#include <string.h>extern char *index();#else#include <strings.h>extern char *strchr(), *strrchr(), *memcpy();#endif#ifdef __STDC__/* Missing include files for GNU C. *//* #include <stdlib.h> */#ifndef macintoshtypedef int size_t;#endif macintoshextern void *calloc(int, size_t);extern void *malloc(size_t);extern void *realloc(void *, size_t);extern void free(void *);extern char *bcopy(), *bzero();#ifdef SOMEDAY#define ISALNUM(c) isalnum(c)#define ISALPHA(c) isalpha(c)#define ISUPPER(c) isupper(c)#else#define ISALNUM(c) (isascii(c) && isalnum(c))#define ISALPHA(c) (isascii(c) && isalpha(c))#define ISUPPER(c) (isascii(c) && isupper(c))#endif#else /* ! __STDC__ */#define consttypedef int size_t;extern char *calloc(), *malloc(), *realloc();extern void free();extern char *bcopy(), ;#define ISALNUM(c) (isascii(c) && isalnum(c))#define ISALPHA(c) (isascii(c) && isalpha(c))#define ISUPPER(c) (isascii(c) && isupper(c))#endif /* ! __STDC__ *//* 1 means plain parentheses serve as grouping, and backslash parentheses are needed for literal searching. 0 means backslash-parentheses are grouping, and plain parentheses are for literal searching. */#define RE_NO_BK_PARENS 1/* 1 means plain | serves as the "or"-operator, and \| is a literal. 0 means \| serves as the "or"-operator, and | is a literal. */#define RE_NO_BK_VBAR 2/* 0 means plain + or ? serves as an operator, and \+, \? are literals. 1 means \+, \? are operators and plain +, ? are literals. */#define RE_BK_PLUS_QM 4/* 1 means | binds tighter than ^ or $. 0 means the contrary. */#define RE_TIGHT_VBAR 8/* 1 means treat \n as an _OR operator 0 means treat it as a normal character */#define RE_NEWLINE_OR 16/* 0 means that a special characters (such as *, ^, and $) always have their special meaning regardless of the surrounding context. 1 means that special characters may act as normal characters in some contexts. Specifically, this applies to: ^ - only special at the beginning, or after ( or | $ - only special at the end, or before ) or | *, +, ? - only special when not after the beginning, (, or | */#define RE_CONTEXT_INDEP_OPS 32/* Now define combinations of bits for the standard possibilities. */#define RE_SYNTAX_AWK (RE_NO_BK_PARENS | RE_NO_BK_VBAR | RE_CONTEXT_INDEP_OPS)#define RE_SYNTAX_EGREP (RE_SYNTAX_AWK | RE_NEWLINE_OR)#define RE_SYNTAX_GREP (RE_BK_PLUS_QM | RE_NEWLINE_OR)#define RE_SYNTAX_EMACS 0/* The NULL pointer. */#define NULL 0/* Number of bits in an unsigned char. */#define CHARBITS 8/* First integer value that is greater than any character code. */#define _NOTCHAR (1 << CHARBITS)/* INTBITS need not be exact, just a lower bound. */#define INTBITS (CHARBITS * sizeof (int))/* Number of ints required to hold a bit for every character. */#define _CHARSET_INTS ((_NOTCHAR + INTBITS - 1) / INTBITS)/* Sets of unsigned characters are stored as bit vectors in arrays of ints. */typedef int _charset[_CHARSET_INTS];/* The regexp is parsed into an array of tokens in postfix form. Some tokens are operators and others are terminal symbols. Most (but not all) of these codes are returned by the lexical analyzer. */#ifdef __STDC__typedef enum{ _END = -1, /* _END is a terminal symbol that matches the end of input; any value of _END or less in the parse tree is such a symbol. Accepting states of the DFA are those that would have a transition on _END. */ /* Ordinary character values are terminal symbols that match themselves. */ _EMPTY = _NOTCHAR, /* _EMPTY is a terminal symbol that matches the empty string. */ _BACKREF, /* _BACKREF is generated by \<digit>; it it not completely handled. If the scanner detects a transition on backref, it returns a kind of "semi-success" indicating that the match will have to be verified with a backtracking matcher. */ _BEGLINE, /* _BEGLINE is a terminal symbol that matches the empty string if it is at the beginning of a line. */ _ALLBEGLINE, /* _ALLBEGLINE is a terminal symbol that matches the empty string if it is at the beginning of a line; _ALLBEGLINE applies to the entire regexp and can only occur as the first token thereof. _ALLBEGLINE never appears in the parse tree; a _BEGLINE is prepended with _CAT to the entire regexp instead. */ _ENDLINE, /* _ENDLINE is a terminal symbol that matches the empty string if it is at the end of a line. */ _ALLENDLINE, /* _ALLENDLINE is to _ENDLINE as _ALLBEGLINE is to _BEGLINE. */ _BEGWORD, /* _BEGWORD is a terminal symbol that matches the empty string if it is at the beginning of a word. */ _ENDWORD, /* _ENDWORD is a terminal symbol that matches the empty string if it is at the end of a word. */ _LIMWORD, /* _LIMWORD is a terminal symbol that matches the empty string if it is at the beginning or the end of a word. */ _NOTLIMWORD, /* _NOTLIMWORD is a terminal symbol that matches the empty string if it is not at the beginning or end of a word. */ _QMARK, /* _QMARK is an operator of one argument that matches zero or one occurences of its argument. */ _STAR, /* _STAR is an operator of one argument that matches the Kleene closure (zero or more occurrences) of its argument. */ _PLUS, /* _PLUS is an operator of one argument that matches the positive closure (one or more occurrences) of its argument. */ _CAT, /* _CAT is an operator of two arguments that matches the concatenation of its arguments. _CAT is never returned by the lexical analyzer. */ _OR, /* _OR is an operator of two arguments that matches either of its arguments. */ _LPAREN, /* _LPAREN never appears in the parse tree, it is only a lexeme. */ _RPAREN, /* _RPAREN never appears in the parse tree. */ _SET /* _SET and (and any value greater) is a terminal symbol that matches any of a class of characters. */} _token;#else /* ! __STDC__ */typedef short _token;#define _END -1#define _EMPTY _NOTCHAR#define _BACKREF (_EMPTY + 1)#define _BEGLINE (_EMPTY + 2)#define _ALLBEGLINE (_EMPTY + 3)#define _ENDLINE (_EMPTY + 4)#define _ALLENDLINE (_EMPTY + 5)#define _BEGWORD (_EMPTY + 6)#define _ENDWORD (_EMPTY + 7)#define _LIMWORD (_EMPTY + 8)#define _NOTLIMWORD (_EMPTY + 9)#define _QMARK (_EMPTY + 10)#define _STAR (_EMPTY + 11)#define _PLUS (_EMPTY + 12)#define _CAT (_EMPTY + 13)#define _OR (_EMPTY + 14)#define _LPAREN (_EMPTY + 15)#define _RPAREN (_EMPTY + 16)#define _SET (_EMPTY + 17)#endif /* ! __STDC__ *//* Sets are stored in an array in the compiled regexp; the index of the array corresponding to a given set token is given by _SET_INDEX(t). */#define _SET_INDEX(t) ((t) - _SET)/* Sometimes characters can only be matched depending on the surrounding context. Such context decisions depend on what the previous character was, and the value of the current (lookahead) character. Context dependent constraints are encoded as 8 bit integers. Each bit that is set indicates that the constraint succeeds in the corresponding context. bit 7 - previous and current are newlines bit 6 - previous was newline, current isn't bit 5 - previous wasn't newline, current is bit 4 - neither previous nor current is a newline bit 3 - previous and current are word-constituents bit 2 - previous was word-constituent, current isn't bit 1 - previous wasn't word-constituent, current is bit 0 - neither previous nor current is word-constituent Word-constituent characters are those that satisfy isalnum(). The macro _SUCCEEDS_IN_CONTEXT determines whether a a given constraint succeeds in a particular context. Prevn is true if the previous character was a newline, currn is true if the lookahead character is a newline. Prevl and currl similarly depend upon whether the previous and current characters are word-constituent letters. */#define _MATCHES_NEWLINE_CONTEXT(constraint, prevn, currn) \ ((constraint) & 1 << ((prevn) ? 2 : 0) + ((currn) ? 1 : 0) + 4)#define _MATCHES_LETTER_CONTEXT(constraint, prevl, currl) \ ((constraint) & 1 << ((prevl) ? 2 : 0) + ((currl) ? 1 : 0))#define _SUCCEEDS_IN_CONTEXT(constraint, prevn, currn, prevl, currl) \ (_MATCHES_NEWLINE_CONTEXT(constraint, prevn, currn) \ && _MATCHES_LETTER_CONTEXT(constraint, prevl, currl))/* The following macros give information about what a constraint depends on. */#define _PREV_NEWLINE_DEPENDENT(constraint) \ (((constraint) & 0xc0) >> 2 != ((constraint) & 0x30))#define _PREV_LETTER_DEPENDENT(constraint) \ (((constraint) & 0x0c) >> 2 != ((constraint) & 0x03))/* Tokens that match the empty string subject to some constraint actually work by applying that constraint to determine what may follow them, taking into account what has gone before. The following values are the constraints corresponding to the special tokens previously defined. */#define _NO_CONSTRAINT 0xff#define _BEGLINE_CONSTRAINT 0xcf#define _ENDLINE_CONSTRAINT 0xaf#define _BEGWORD_CONSTRAINT 0xf2#define _ENDWORD_CONSTRAINT 0xf4#define _LIMWORD_CONSTRAINT 0xf6#define _NOTLIMWORD_CONSTRAINT 0xf9/* States of the recognizer correspond to sets of positions in the parse tree, together with the constraints under which they may be matched. So a position is encoded as an index into the parse tree together with a constraint. */typedef struct{ unsigned index; /* Index into the parse array. */ unsigned constraint; /* Constraint for matching this position. */} _position;/* Sets of positions are stored as arrays. */typedef struct{ _position *elems; /* Elements of this position set. */ int nelem; /* Number of elements in this set. */} _position_set;/* A state of the regexp consists of a set of positions, some flags, and the token value of the lowest-numbered position of the state that contains an _END token. */typedef struct{ int hash; /* Hash of the positions of this state. */ _position_set elems; /* Positions this state could match. */ char newline; /* True if previous state matched newline. */ char letter; /* True if previous
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:gnu grep 1.5 ƒ:dfa.h
+++++ Continued from previous card +++++
state matched a letter. */ char backref; /* True if this state matches a \<digit>. */ unsigned char constraint; /* Constraint for this state to accept. */ int first_end; /* Token value of the first _END in elems. */} _dfa_state;/* If an r.e. is at most MUST_MAX characters long, we look for a string which must appear in it; whatever's found is dropped into the struct reg. */#define MUST_MAX 50/* A compiled regular expression. */struct regexp{ /* Stuff built by the scanner. */ _charset *charsets; /* Array of character sets for _SET tokens. */ int cindex; /* Index for adding new charsets. */ int calloc; /* Number of charsets currently allocated. */ /* Stuff built by the parser. */ _token *tokens; /* Postfix parse array. */ int tindex; /* Index for adding new tokens. */ int talloc; /* Number of tokens currently allocated. */ int depth; /* Depth required of an evaluation stack used for depth-first traversal of the parse tree. */ int nleaves; /* Number of leaves on the parse tree. */ int nregexps; /* Count of parallel regexps being built with regparse(). */ /* Stuff owned by the state builder. */ _dfa_state *states; /* States of the regexp. */ int sindex; /* Index for adding new states. */ int salloc; /* Number of states currently allocated. */ /* Stuff built by the structure analyzer. */ _position_set *follows; /* Array of follow sets, indexed by position index. The follow of a position is the set of positions containing characters that could conceivably follow a character matching the given position in a string matching the regexp. Allocated to the maximum possible position index. */ int searchflag; /* True if we are supposed to build a searching as opposed to an exact matcher. A searching matcher finds the first and shortest string matching a regexp anywhere in the buffer, whereas an exact matcher finds the longest string matching, but anchored to the beginning of the buffer. */ /* Stuff owned by the executor. */ int tralloc; /* Number of transition tables that have slots so far. */ int trcount; /* Number of transition tables that have actually been built. */ int **trans; /* Transition tables for states that can never accept. If the transitions for a state have not yet been computed, or the state could possibly accept, its entry in this table is NULL. */ int **realtrans; /* Trans always points to realtrans + 1; this is so trans[-1] can contain NULL. */ int **fails; /* Transition tables after failing to accept on a state that potentially could do so. */ int *success; /* Table of acceptance conditions used in regexecute and computed in build_state. */ int *newlines; /* Transitions on newlines. The entry for a newline in any transition table is always -1 so we can count lines without wasting too many cycles. The transition for a newline is stored separately and handled as a special case. Newline is also used as a sentinel at the end of the buffer. */ char must[MUST_MAX]; int mustn;};/* Some macros for user access to regexp internals. *//* ACCEPTING returns true if s could possibly be an accepting state of r. */#define ACCEPTING(s, r) ((r).states[s].constraint)/* ACCEPTS_IN_CONTEXT returns true if the given state accepts in the specified context. */#define ACCEPTS_IN_CONTEXT(prevn, currn, prevl, currl, state, reg) \ _SUCCEEDS_IN_CONTEXT((reg).states[state].constraint, \ prevn, currn, prevl, currl)/* FIRST_MATCHING_REGEXP returns the index number of the first of parallel regexps that a given state could accept. Parallel regexps are numbered starting at 1. */#define FIRST_MATCHING_REGEXP(state, reg) (-(reg).states[state].first_end)/* Entry points. */#ifdef __STDC__/* Regsyntax() takes two arguments; the first sets the syntax bits described earlier in this file, and the second sets the case-folding flag. */extern void regsyntax(int, int);/* Compile the given string of the given length into the given struct regexp. Final argument is a flag specifying whether to build a searching or an exact matcher. */extern void regcompile(const char *, size_t, struct regexp *, int);/* Execute the given struct regexp on the buffer of characters. The first char * points to the beginning, and the second points to the first character after the end of the buffer, which must be a writable place so a sentinel end-of-buffer marker can be stored there. The second-to-last argument is a flag telling whether to allow newlines to be part of a string matching the regexp. The next-to-last argument, if non-NULL, points to a place to increment every time we see a newline. The final argument, if non-NULL, points to a flag that will be set if further examination by a backtracking matcher is needed in order to verify backreferencing; otherwise the flag will be cleared. Returns NULL if no match is found, or a pointer to the first character after the first & shortest matching string in the buffer. */extern char *regexecute(struct regexp *, char *, char *, int, int *, int *);/* Free the storage held by the components of a struct regexp. */extern void regfree(struct regexp *);/* Entry points for people who know what they're doing. *//* Initialize the components of a struct regexp. */extern void reginit(struct regexp *);/* Incrementally parse a string of given length into a struct regexp. */extern void regparse(const char *, size_t, struct regexp *);/* Analyze a parsed regexp; second argument tells whether to build a searching or an exact matcher. */extern void reganalyze(struct regexp *, int);/* Compute, for each possible character, the transitions out of a given state, storing them in an array of integers. */extern void regstate(int, struct regexp *, int []);/* Error handling. *//* Regerror() is called by the regexp routines whenever an error occurs. It takes a single argument, a NUL-terminated string describing the error. The default regerror() prints the error message to stderr and exits. The user can provide a different regfree() if so desired. */extern void regerror(const char *);#else /* ! __STDC__ */extern void regsyntax(), regcompile(), regfree(), reginit(), regparse();extern void reganalyze(), regstate(), regerror();extern char *regexecute();#endif :MPW:MPW Tools:Tools with Source:gnu grep 1.5 ƒ:egrep.make
/* Getopt for GNU. Copyright (C) 1987 Free Software Foundation, Inc. NO WARRANTY BECAUSE THIS PROGRAM IS LICENSED FREE OF CHARGE, WE PROVIDE ABSOLUTELYNO WARRANTY, TO THE EXTENT PERMITTED BY APPLICABLE STATE LAW. EXCEPTWHEN OTHERWISE STATED IN WRITING, FREE SOFTWARE FOUNDATION, INC,RICHARD M. STALLMAN AND/OR OTHER PARTIES PROVIDE THIS PROGRAM "AS IS"WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING,BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY ANDFITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITYAND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVEDEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR ORCORRECTION. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW WILL RICHARD M.STALLMAN, THE FREE SOFTWARE FOUNDATION, INC., AND/OR ANY OTHER PARTYWHO MAY MODIFY AND REDISTRIBUTE THIS PROGRAM AS PERMITTED BELOW, BELIABLE TO YOU FOR DAMAGES, INCLUDING ANY LOST PROFITS, LOST MONIES, OROTHER SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THEUSE OR INABILITY TO USE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA ORDATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY THIRD PARTIES ORA FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS) THISPROGRAM, EVEN IF YOU HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCHDAMAGES, OR FOR ANY CLAIM BY ANY OTHER PARTY. GENERAL PUBLIC LICENSE TO COPY 1. You may copy and distribute verbatim copies of this source fileas you receive it, in any medium, provided that you conspicuously andappropriately publish on each copy a valid copyright notice "Copyright (C) 1987 Free Software Foundation, Inc."; and include following thecopyright notice a verbatim copy of the above disclaimer of warrantyand of this License. You may charge a distribution fee for thephysical act of transferring a copy. 2. You may modify your copy or copies of this source file orany portion of it, and copy and distribute such modifications underthe terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains or is a derivative of this program or any part thereof, to be licensed at no charge to all third parties on terms identical to those contained in this License Agreement (except that you may choose to grant more extensive warranty protection to third parties, at your option). c) You may charge a distribution fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 3. You may copy and distribute this program or any portion of it incompiled, executable or object code form under the terms of Paragraphs1 and 2 above provided that you do the following: a) cause each such copy to be accompanied by the corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) cause each such copy to be accompanied by a written offer, with no time limit, to give any third party free (except for a nominal shipping charge) a machine readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) in the case of a recipient of this program in compiled, executable or object code form (without the corresponding source code) you shall cause copies you distribute to be accompanied by a copy of the written offer of source code which you received along with the copy you received. 4. You may not copy, sublicense, distribute or transfer this programexcept as expressly provided under this License Agreement. Any attemptotherwise to copy, sublicense, distribute or transfer this program is void andyour rights to use the program under this License agreement shall beautomatically terminated. However, parties who have received computersoftware programs from you with this License Agreement will not havetheir licenses terminated so long as such parties remain in full compliance. 5. If you wish to incorporate parts of this program into other freeprograms whose distribution conditions are different, write to the FreeSoftware Foundation at 675 Mass Ave, Cambridge, MA 02139. We have not yetworked out a simple rule that can be stated here, but we will often permitthis. We will be guided by the two goals of preserving the free status ofall derivatives of our free software and of promoting the sharing and reuse ofsoftware.In other words, you are welcome to use, share and improve this program.You are forbidden to forbid anyone else to use, share and improvewhat you give them. Help stamp out software-hoarding! */ /* This version of `getopt' appears to the caller like standard Unix `getopt' but it behaves differently for the user, since it allows the user to intersperse the options with the other arguments. As `getopt' works, it permutes the elements of `argv' so that, when it is done, all the options precede everything else. Thus all application programs are extended to handle flexible argument order. Setting the environment variable _POSIX_OPTION_ORDER disables permutation. Then the behavior is completely standard. GNU application programs can use a third alternative mode in which they can distinguish the relative order of options and other arguments. */#include <stdio.h>#ifdef sparc#include <alloca.h>#endif#ifdef USG#define bcopy(s, d, l) memcpy((d), (s), (l))#endif/* For communication from `getopt' to the caller. When `getopt' finds an option that takes an argument, the argument value is returned here. Also, when `ordering' is RETURN_IN_ORDER, each non-option ARGV-element is returned here. */char *optarg = 0;/* Index in ARGV of the next element to be scanned. This is used for communication to and from the caller and for communication between successive calls to `getopt'. On entry to `getopt', zero means this is the first call; initialize. When `getopt' returns EOF, this is the index of the first of the non-option elements that the caller should itself scan. Otherwise, `optind' communicates from one call to the next how much of ARGV has been scanned so far. */int optind = 0;/* The next char to be scanned in the option-element in which the last option character we returned was found. This allows us to pick up the scan where we left off. If this is zero, or a null string, it means resume the scan by advancing to the next ARGV-element. */static char *nextchar;/* Callers store zero here to inhibit the error message for unrecognized options. */int opterr = 1;/* Describe how to deal with options that follow non-option ARGV-elements. UNSPECIFIED means the caller did not specify anything; the default is then REQUIRE_ORDER if the environment variable _OPTIONS_FIRST is defined, PERMUTE otherwise. REQUIRE_ORDER means don't recognize them as options. Stop option processing when the first non-option is seen. This is what Unix does. PERMUTE is the default. We permute the contents of `argv' as we scan, so that eventually all the options are at the end. This allows options to be given in any order, even with programs that were not written to expect this. RETURN_IN_ORDER is an option available to programs that were written to expect options and other ARGV-elements in any order and that care about the ordering of the two. We describe each non-option ARGV-element as if it were the argument of an option with character code zero. Using `-' as the first character of the list of option characters requests this mode of operation. The special argument `--' forces an end of option-scanning regardless of the value of `ordering'. In the case of RETURN_IN_ORDER, only `--' can cause `getopt' to return EOF with `optind' != ARGC. */static enum { REQUIRE_ORDER, PERMUTE, RETURN_IN_ORDER } ordering; /* Handle permutation of arguments. *//* Describe the part of ARGV that contains non-options that have been skipped. `first_nonopt' is the index in ARGV of the first of them; `last_nonopt' is the index after the last of them. */static int first_nonopt;static int last_nonopt;/* Exchange two adjacent subsequences of ARGV. One subsequence is elements [first_nonopt,last_nonopt) which contains all the non-options that have been skipped so far. The other is elements [last_nonopt,optind), which contains all the options processed since those non-options were skipped. `first_nonopt' and `last_nonopt' are relocated so that they describe the new indices of the non-options in ARGV after they are moved. */static voidexchange (argv) char **argv;{ int nonopts_size = (last_nonopt - first_nonopt) * sizeof (char *); char **temp = (char **) alloca (nonopts_size); /* Interchange the two blocks of data in argv. */ bcopy (&argv[first_nonopt], temp, nonopts_size); bcopy (&argv[last_nonopt], &argv[first_nonopt], (optind - last_nonopt) * sizeof (char *)); bcopy (temp, &argv[first_nonopt + optind - last_nonopt], nonopts_size); /* Update records for the slots the non-options now occupy. */ first_nonopt += (optind - last_nonopt); last_nonopt = optind;} /* Scan elements of ARGV (whose length is ARGC) for option characters given in OPTSTRING. If an element of ARGV starts with '-', and is not exactly "-" or "--", then it is an option element. The characters of this element (aside from the initial '-') are option characters. If `getopt' is called repeatedly, it returns successively each of theoption characters from each of the option elements. If `getopt' finds another option character, it returns that character, updating `optind' and `nextchar' so that the next call to `getopt' can resume the scan with the following option character or ARGV-element. If there are no more option characters, `getopt' returns `EOF'. Then `optind' is the index in ARGV of the first ARGV-element that is not an option. (The ARGV-elements have been permuted so that those that are not options now come last.) OPTSTRING is a string containing the legitimate option characters. A colon in OPTSTRING means that the previous character is an option that wants an argument. The argument is taken from the rest of the current ARGV-element, or from the following ARGV-element, and returned in `optarg'. If an option character is seen that is not listed in OPTSTRING, return '?' after printing an error message. If you set `opterr' to zero, the error message is suppressed but we still return '?'. If a char in OPTSTRING is followed by a colon, that means it wants an arg, so the following text in the same ARGV-element, or the text of the following ARGV-element, is returned in `optarg. Two colons mean an option that wants an optional arg; if there is text in the current ARGV-element, it is returned in `optarg'. If OPTSTRING starts with `-', it requests a different method of handling the non-option ARGV-elements. See the comments about RETURN_IN_ORDER, above. */intgetopt (argc, argv, optstring) int argc; char **argv; char *optstring;{ /* Initialize the internwhen the first call is made. Start processing options with ARGV-element 1 (since ARGV-element 0 is the program name); the sequence of previously skipped non-option ARGV-elements is empty. */ if (optind == 0) { first_nonopt = last_nonopt = optind = 1; nextchar = 0; /* Determine how to handle the ordering of options and nonoptions. */ if (optstring[0] == '-') ordering = RETURN_IN_ORDER; else if (getenv ("_POSIX_OPTION_ORDER") != 0) ordering = REQUIRE_ORDER; else ordering = PERMUTE; } if (nextchar == 0 || *nextchar == 0) { if (ordering == PERMUTE) { /* If we have just processed some options following some non-options, exchange them so that the options come first. */ if (first_nonopt != last_nonopt && last_nonopt != optind) exchange (argv); else if (last_nonopt != optind) first_nonopt = optind; /* Now skip any additional non-options and extend the range of non-options previously skipped. */ while (optind < argc && (argv[optind][0] != '-' || argv[optind][1] == 0)) optind++; last_nonopt = optind; } /* Special ARGV-element `--' means premature end of options. Skip it like a null option, then exchange with previous non-options as if it were an option, then skip everything else like a non-option. */ if (optind != argc && !strcmp (argv[optind], "--")) { optind++; if (first_nonopt != last_nonopt && last_nonopt != optind) exchange (argv); else if (first_nonopt == last_nonopt) first_nonopt = optind; last_nonopt = argc; optind = argc; } /* If we have done all the ARGV-elements, stop the scan and back over any non-options that we skipped and permuted. */ if (optind == argc) { /* Set the next-arg-index to point at the non-options that we previously skipped, so the caller will digest them. */ if (first_nonopt != last_nonopt) optind = first_nonopt; return EOF; } /* If we have come to a non-option and did not permute it, either stop the scan or describe it to the caller and pass it by. */ if (argv[optind][0] != '-' || argv[optind][1] == 0) { if (ordering == REQUIRE_ORDER) return EOF; optarg = argv[optind++]; return 0; } /* We have found another option-ARGV-element. Start decoding its characters. */ nextchar = argv[optind] + 1; } /* Look at and handle the next option-character. */ { char c = *nextchar++; char *temp = (char *) index (optstring, c); /* Increment `optind' when we start to process its last character. */ if (*nextchar == 0) optind++; if (temp == 0 || c == ':') { if (opterr != 0) { if (c < 040 || c >= 0177) fprintf (stderr, "%s: unrecognized option, character code 0%o\n", argv[0], c); else fprintf (stderr, "%s: unrecognized option `-%c'\n", argv[0], c); } return '?'; } if (temp[1] == ':') { if (temp[2] == ':') { /* This is an option that accepts an argument optionally. */ if (*nextchar != 0) { optarg = nextchar; optind++; } else optarg = 0; nextchar = 0; } else { /* This is an option that requires an argument. */ if (*nextchar != 0) { optarg = nextchar; /* If we end this ARGV-element by taking the rest as an arg, we must advance to the next element now. */ optind++; } else if (optind == argc) { if (opterr != 0) fprintf (stderr, "%s: no argument for `-%c' option\n", argv[0], c); c = '?'; } else /* We already incremented `optind' once; increment it again when taking next ARGV-elt as argument. */ optarg = argv[optind++]; nextchar = 0; } } return c; }} #ifdef TEST/* Compile with -DTEST to make an executable for use in testing the above definition of `getopt'. */intmain (argc, argv) int argc; char **argv;{ char c; int digit_optind = 0; while (1) { int this_option_optind = optind; if ((c = getopt (argc, argv, "abc:d:0123456789")) == EOF) break; switch (c) { case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': if (digit_optind !=
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:gnu grep 1.5 ƒ:getopt.c
+++++ Continued from previous card +++++
0 && digit_optind != this_option_optind) printf ("digits occur in two different argv-elements.\n"); digit_optind = this_option_optind; printf ("option %c\n", c); break; case 'a': printf ("option a\n"); break; case 'b': printf ("option b\n"); break; case 'c': printf ("option c with value `%s'\n", optarg); break; case '?': break; default: printf ("?? getopt returned character code 0%o ??\n", c); } } if (optind < argc) { printf ("non-option ARGV-elements: "); while (optind < argc) printf ("%s ", argv[optind++]); printf ("\n"); } return 0;}#endif /* TEST */ :MPW:MPW Tools:Tools with Source:gnu grep 1.5 ƒ:grep.c
/* grep - print lines matching an extended regular expression Copyright (C) 1988 Free Software Foundation, Inc. Written June, 1988 by Mike Haertel BMG speedups added July, 1988 by James A. Woods and Arthur David Olson NO WARRANTY BECAUSE THIS PROGRAM IS LICENSED FREE OF CHARGE, WE PROVIDE ABSOLUTELYNO WARRANTY, TO THE EXTENT PERMITTED BY APPLICABLE STATE LAW. EXCEPTWHEN OTHERWISE STATED IN WRITING, FREE SOFTWARE FOUNDATION, INC,RICHARD M. STALLMAN AND/OR OTHER PARTIES PROVIDE THIS PROGRAM "AS IS"WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING,BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY ANDFITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITYAND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVEDEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR ORCORRECTION. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW WILL RICHARD M.STALLMAN, THE FREE SOFTWARE FOUNDATION, INC., AND/OR ANY OTHER PARTYWHO MAY MODIFY AND REDISTRIBUTE THIS PROGRAM AS PERMITTED BELOW, BELIABLE TO YOU FOR DAMAGES, INCLUDING ANY LOST PROFITS, LOST MONIES, OROTHER SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THEUSE OR INABILITY TO USE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA ORDATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY THIRD PARTIES ORA FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS) THISPROGRAM, EVEN IF YOU HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCHDAMAGES, OR FOR ANY CLAIM BY ANY OTHER PARTY. GENERAL PUBLIC LICENSE TO COPY 1. You may copy and distribute verbatim copies of this source fileas you receive it, in any medium, provided that you conspicuously andappropriately publish on each copy a valid copyright notice "Copyright (C) 1988 Free Software Foundation, Inc."; and include following thecopyright notice a verbatim copy of the above disclaimer of warrantyand of this License. You may charge a distribution fee for thephysical act of transferring a copy. 2. You may modify your copy or copies of this source file orany portion of it, and copy and distribute such modifications underthe terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains or is a derivative of this program or any part thereof, to be licensed at no charge to all third parties on terms identical to those contained in this License Agreement (except that you may choose to grant more extensive warranty protection to some or all third parties, at your option). c) You may charge a distribution fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee.Mere aggregation of another unrelated program with this program (or itsderivative) on a volume of a storage or distribution medium does not bringthe other program under the scope of these terms. 3. You may copy and distribute this program or any portion of it incompiled, executable or object code form under the terms of Paragraphs1 and 2 above provided that you do the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal shipping charge) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.)For an executable file, complete source code means all the source code forall modules it contains; but, as a special exception, it need not includesource code for modules which are standard libraries that accompany theoperating system on which the executable file runs. 4. You may not copy, sublicense, distribute or transfer this programexcept as expressly provided under this License Agreement. Any attemptotherwise to copy, sublicense, distribute or transfer this program is void andyour rights to use the program under this License agreement shall beautomatically terminated. However, parties who have received computersoftware programs from you with this License Agreement will not havetheir licenses terminated so long as such parties remain in full compliance. 5. If you wish to incorporate parts of this program into other freeprograms whose distribution conditions are different, write to the FreeSoftware Foundation at 675 Mass Ave, Cambridge, MA 02139. We have not yetworked out a simple rule that can be stated here, but we will often permitthis. We will be guided by the two goals of preserving the free status ofall derivatives our free software and of promoting the sharing and reuse ofsoftware.In other words, you are welcome to use, share and improve this program.You are forbidden to forbid anyone else to use, share and improvewhat you give them. Help stamp out software-hoarding! */ #include <ctype.h>#include <stdio.h>#ifdef USG#include <memory.h>#include <string.h>#else#include <strings.h>#endif#include "dfa.h"#include "regex.h"#ifdef __STDC__extern getopt(int, char **, const char *);extern read(int, void *, int);extern open(const char *, int, ...);extern void close();#elseextern char *strrchr();#endifextern char *optarg;extern optind, opterr;extern errno;extern char *sys_errlist[];#define MAX(a, b) ((a) > (b) ? (a) : (b))/* Exit status codes. */#define MATCHES_FOUND 0 /* Exit 0 if no errors and matches found. */#define NO_MATCHES_FOUND 1 /* Exit 1 if no matches were found. */#define ERROR 2 /* Exit 2 if some error occurred. *//* Error is set true if something awful happened. */static int error;/* The program name for error messages. */static char *prog;/* We do all our own buffering by hand for efficiency. */static char *buffer; /* The buffer itself, grown as needed. */static bufbytes; /* Number of bytes in the buffer. */static size_t bufalloc; /* Number of bytes allocated to the buffer. */static bufprev; /* Number of bytes that have been forgotten. This is used to get byte offsets from the beginning of the file. */static bufread; /* Number of bytes to get with each read(). */static voidinitialize_buffer(){ bufread = 8192; bufalloc = bufread + bufread / 2; buffer = malloc(bufalloc); if (! buffer) { fprintf(stderr, "%s: Memory exhausted (%s)\n", prog,#ifdef macintosh "???");#else sys_errlist[errno]);#endif macintosh exit(ERROR); }}/* The current input file. */static fd;static char *filename;static eof;/* Fill the buffer retaining the last n bytes at the beginning of the newly filled buffer (for backward context). Returns the number of new bytes read from disk. */staticfill_buffer_retaining(n) int n;{ char *p, *q; int i; /* See if we need to grow the buffer. */ if (bufalloc - n <= bufread) { while (bufalloc - n <= bufread) { bufalloc *= 2; bufread *= 2; } buffer = realloc(buffer, bufalloc); if (! buffer) { fprintf(stderr, "%s: Memory exhausted (%s)\n", prog,#ifdef macintosh "???");#else sys_errlist[errno]);#endif macintosh exit(ERROR); } } bufprev += bufbytes - n; /* Shift stuff down. */ for (i = n, p = buffer, q = p + bufbytes - n; i--; ) *p++ = *q++; bufbytes = n; if (eof) return 0; /* Read in new stuff. */ i = read(fd, buffer + bufbytes, bufread); if (i < 0) { fprintf(stderr, "%s: read on %s failed (%s)\n", prog, filename ? filename : "<stdin>",#ifdef macintosh "???");#else sys_errlist[errno]);#endif macintosh error = 1; } /* Kludge to pretend every nonempty file ends with a newline. */ if (i == 0 && bufbytes > 0 && buffer[bufbytes - 1] != '\n') { eof = i = 1; buffer[bufbytes] = '\n'; } bufbytes += i; return i;} /* Various flags set according to the argument switches. */static trailing_context; /* Lines of context to show after matches. */static leading_context; /* Lines of context to show before matches. */static byte_count; /* Precede output lines the byte count of the first character on the line. */static no_filenames; /* Do not display filenames. */static line_numbers; /* Precede output lines with line numbers. */static silent; /* Produce no output at all. This switch is bogus, ever hear of /dev/null? */static nonmatching_lines; /* Print lines that don't match the regexp. */static bmgexec; /* Invoke Boyer-Moore-Gosper routines *//* The compiled regular expression lives here. */static struct regexp reg;/* The compiled regular expression for the backtracking matcher lives here. */static struct re_pattern_buffer regex;/* Pointer in the buffer after the last character printed. */static char *printed_limit;/* True when printed_limit has been artifically advanced without printing anything. */static int printed_limit_fake;/* Print a line at the given line number, returning the number of characters actually printed. Matching is true if the line is to be considered a "matching line". This is only meaningful if surrounding context is turned on. */staticprint_line(p, number, matching) char *p; int number; int matching;{ int count = 0; if (silent) { do ++count; while (*p++ != '\n'); printed_limit_fake = 0; printed_limit = p; return count; } if (filename && !no_filenames) printf("%s%c", filename, matching ? ':' : '-'); if (byte_count) printf("%d%c", p - buffer + bufprev, matching ? ':' : '-'); if (line_numbers) printf("%d%c", number, matching ? ':' : '-'); do { ++count; putchar(*p); } while (*p++ != '\n'); printed_limit_fake = 0; printed_limit = p; return count;}/* Print matching or nonmatching lines from the current file. Returns a count of matching or nonmatching lines. */staticgrep(){ int retain = 0; /* Number of bytes to retain on next call to fill_buffer_retaining(). */ char *search_limit; /* Pointer to the character after the last newline in the buffer. */ char saved_char; /* Character after the last newline. */ char *resume; /* Pointer to where to resume search. */ int resume_index = 0; /* Count of characters to ignore after refilling the buffer. */ int line_count = 1; /* Line number. */ int try_backref; /* Set to true if we need to verify the match with a backtracking matcher. */ int initial_line_count; /* Line count at beginning of last search. */ char *match; /* Pointer to the first character after the string matching the regexp. */ int match_count = 0; /* Count of matching lines. */ char *matching_line; /* Pointer to first character of the matching line, or of the first line of context to print if context is turned on. */ char *real_matching_line; /* Pointer to the first character of the real matching line. */ char *next_line; /* Pointer to first character of the line following the matching line. */ int pending_lines = 0; /* Lines of context left over from last match that we have to print. */ static first_match = 1; /* True when nothing has been printed. */ int i; char *tmp; char *execute(); printed_limit_fake = 0; while (fill_buffer_retaining(retain) > 0) { /* Find the last newline in the buffer. */ search_limit = buffer + bufbytes; while (search_limit > buffer && search_limit[-1] != '\n') --search_limit; if (search_limit == buffer) { retain = bufbytes; continue; } /* Save the character after the last newline so regexecute can write its own sentinel newline. */ saved_char = *search_limit; /* Search the buffer for a match. */ printed_limit = buffer; resume = buffer + resume_index; initial_line_count = line_count; while (match = execute(®, resume, search_limit, 0, &line_count, &try_backref)) { ++match_count; /* Find the beginning of the matching line. */ matching_line = match; while (matching_line > resume && matching_line[-1] != '\n') --matching_line; real_matching_line = matching_line; /* Find the beginning of the next line. */ next_line = match; while (next_line < search_limit && *next_line++ != '\n') ; /* If a potential backreference is indicated, try it out with a backtracking matcher to make sure the line is a match. */ if (try_backref && re_search(®ex, matching_line, next_line - matching_line - 1, 0, next_line - matching_line - 1, NULL) < 0) { resume = next_line; if (resume == search_limit) break; else continue; } /* Print leftover lines from last time. If nonmatching_lines is turned on, print these as if they were matching lines. */ while (resume < matching_line && pending_lines) { resume += print_line(resume, initial_line_count++, nonmatching_lines); --pending_lines; } /* Print out the matching or nonmatching lines as necessary. */ if (! nonmatching_lines) { /* Back up over leading context if necessary. */ for (i = leading_context; matching_line > printed_limit && i; --i) { while (matching_line > printed_limit && (--matching_line)[-1] != '\n') ; --line_count; } /* If context is enabled, we may have to print a separator. */ if ((leading_context || trailing_context) && !silent && !first_match && (printed_limit_fake || matching_line > printed_limit)) printf("----------\n"); first_match = 0; /* Print the matching line and its leading context. */ while (matching_line < real_matching_line) matching_line += print_line(matching_line, line_count++, 0); matching_line += print_line(matching_line, line_count++, 1); /* If there's trailing context, leave some lines pending until next time. */ pending_lines = trailing_context; } else if (matching_line > resume) { char *real_resume = resume; /* Back up over leading context if necessary. */ for (i = leading_context; resume > printed_limit && i; --i) { while (resume > printed_limit && (--resume)[-1] != '\n') ; --initial_line_count; } /* If context is enabled, we may have to print a separator. */ if ((leading_context || trailing_context) && !silent && !first_match && (printed_limit_fake || resume > printed_limit)) printf("----------\n"); first_match = 0; /* Print out the presumably matching leading context. */ while (resume < real_resume) resume += print_line(resume, initial_line_count++, 0); /* Print out the nonmatching lines prior to the matching line. */ while (resume < matching_line) resume += print_line(resume, initial_line_count++, 1); /* Deal with trailing context. */ if (trailing_context) { print_line(matching_line, line_count, 0); pending_lines = trailing_context - 1; } /* Count the current line. */ ++line_count; } else { /* The line immediately aft
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:gnu grep 1.5 ƒ:grep.c
+++++ Continued from previous card +++++
er a matching line has to be printed because it was pending. */ if (pending_lines > 0) { --pending_lines; print_line(matching_line, line_count, 0); } ++line_count; } /* Resume searching at the beginning of the next line. */ initial_line_count = line_count; resume = next_line; if (resume == search_limit) break; } /* Restore the saved character. */ *search_limit = saved_char; if (! nonmatching_lines) { while (resume < search_limit && pending_lines) { resume += print_line(resume, initial_line_count++, 0); --pending_lines; } } else if (search_limit > resume) { char *initial_resume = resume; /* Back up over leading context if necessary. */ for (i = leading_context; resume > printed_limit && i; --i) { while (resume > printed_limit && (--resume)[-1] != '\n') ; --initial_line_count; } /* If context is enabled, we may have to print a separator. */ if ((leading_context || trailing_context) && !silent && !first_match && (printed_limit_fake || resume > printed_limit)) printf("----------\n"); first_match = 0; /* Print out all the nonmatching lines up to the search limit. */ while (resume < initial_resume) resume += print_line(resume, initial_line_count++, 0); while (resume < search_limit) resume += print_line(resume, initial_line_count++, 1); pending_lines = trailing_context; resume_index = 0; retain = bufbytes - (search_limit - buffer); continue; } /* Save the trailing end of the buffer for possible use as leading context in the future. */ i = leading_context; tmp = search_limit; while (tmp > printed_limit && i--) while (tmp > printed_limit && (--tmp)[-1] != '\n') ; resume_index = search_limit - tmp; retain = bufbytes - (tmp - buffer); if (tmp > printed_limit) printed_limit_fake = 1; } return nonmatching_lines ? (line_count - 1) - match_count : match_count;} voidusage_and_die(){ fprintf(stderr,"usage: %s [-CVbchilnsvwx] [-<num>] [-AB <num>] [-f file] [-e] expr [files]\n", prog); exit(ERROR);}static char version[] = "GNU e?grep, version 1.5";main(argc, argv) int argc; char **argv;{ int c; int ignore_case = 0; /* Compile the regexp to ignore case. */ char *the_regexp = 0; /* The regular expression. */ int regexp_len; /* Length of the regular expression. */ char *regexp_file = 0; /* File containing parallel regexps. */ int count_lines = 0; /* Display only a count of matching lines. */ int list_files = 0; /* Display only the names of matching files. */ int whole_word = 0; /* Insist that the regexp match a word only. */ int whole_line = 0; /* Insist on matching only whole lines. */ int line_count = 0; /* Count of matching lines for a file. */ int matches_found = 0; /* True if matches were found. */ char *regex_errmesg; /* Error message from regex routines. */ char translate[_NOTCHAR]; /* Translate table for case conversion (needed by the backtracking matcher). */ if (prog = strrchr(argv[0], '/')) ++prog; else prog = argv[0]; opterr = 0; while ((c = getopt(argc, argv, "0123456789A:B:CVbce:f:hilnsvwx")) != EOF) switch (c) { case '?': usage_and_die(); break; case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': trailing_context = 10 * trailing_context + c - '0'; leading_context = 10 * leading_context + c - '0'; break; case 'A': if (! sscanf(optarg, "%d", &trailing_context) || trailing_context < 0) usage_and_die(); break; case 'B': if (! sscanf(optarg, "%d", &leading_context) || leading_context < 0) usage_and_die(); break; case 'C': trailing_context = leading_context = 2; break; case 'V': fprintf(stderr, "%s\n", version); break; case 'b': byte_count = 1; break; case 'c': count_lines = 1; silent = 1; break; case 'e': /* It doesn't make sense to mix -f and -e. */ if (regexp_file) usage_and_die(); the_regexp = optarg; break; case 'f': /* It doesn't make sense to mix -f and -e. */ if (the_regexp) usage_and_die(); regexp_file = optarg; break; case 'h': no_filenames = 1; break; case 'i': ignore_case = 1; for (c = 0; c < _NOTCHAR; ++c) if (isupper(c)) translate[c] = tolower(c); else translate[c] = c; regex.translate = translate; break; case 'l': list_files = 1; silent = 1; break; case 'n': line_numbers = 1; break; case 's': silent = 1; break; case 'v': nonmatching_lines = 1; break; case 'w': whole_word = 1; break; case 'x': whole_line = 1; break; default: /* This can't happen. */ fprintf(stderr, "%s: getopt(3) let one by!\n", prog); usage_and_die(); break; } /* Set the syntax depending on whether we are EGREP or not. */#ifdef EGREP regsyntax(RE_SYNTAX_EGREP, ignore_case); re_set_syntax(RE_SYNTAX_EGREP);#else regsyntax(RE_SYNTAX_GREP, ignore_case); re_set_syntax(RE_SYNTAX_GREP);#endif /* Compile the regexp according to all the options. */ if (regexp_file) { FILE *fp = fopen(regexp_file, "r"); int len = 256; int i = 0; if (! fp) { fprintf(stderr, "%s: %s: %s\n", prog, regexp_file,#ifdef macintosh "???");#else sys_errlist[errno]);#endif macintosh exit(ERROR); } the_regexp = malloc(len); while ((c = getc(fp)) != EOF) { the_regexp[i++] = c; if (i == len) the_regexp = realloc(the_regexp, len *= 2); } fclose(fp); /* Nuke the concluding newline so we won't match the empty string. */ if (i > 0 && the_regexp[i - 1] == '\n') --i; regexp_len = i; } else if (! the_regexp) { if (optind >= argc) usage_and_die(); the_regexp = argv[optind++]; regexp_len = strlen(the_regexp); } else regexp_len = strlen(the_regexp); if (whole_word || whole_line) { char *n = malloc(regexp_len + 8); int i = 0; if (whole_line) n[i++] = '^'; else n[i++] = '\\', n[i++] = '<';#ifndef EGREP n[i++] = '\\';#endif n[i++] = '('; memcpy(n + i, the_regexp, regexp_len); i += regexp_len;#ifndef EGREP n[i++] = '\\';#endif n[i++] = ')'; if (whole_line) n[i++] = '$'; else n[i++] = '\\', n[i++] = '>'; the_regexp = n; regexp_len = i; } regcompile(the_regexp, regexp_len, ®, 1); if (regex_errmesg = re_compile_pattern(the_regexp, regexp_len, ®ex)) regerror(regex_errmesg); /* Find the longest metacharacter-free string which must occur in the regexpr, before short-circuiting regexecute() with Boyer-Moore-Gosper. (Conjecture: The problem in general is NP-complete.) If there is no such string (like for many alternations), then default to full automaton search. regmust() code and heuristics [see dfa.c] courtesy Arthur David Olson. */ if (line_numbers == 0 && nonmatching_lines == 0) { if (reg.mustn == 0 || reg.mustn == MUST_MAX || strchr(reg.must, '\0') != reg.must + reg.mustn) bmgexec = 0; else { reg.must[reg.mustn] = '\0'; if (getenv("MUSTDEBUG") != NULL) (void) printf("must have: \"%s\"\n", reg.must); bmg_setup(reg.must, ignore_case); bmgexec = 1; } } if (argc - optind < 2) no_filenames = 1; initialize_buffer(); if (argc > optind) while (optind < argc) { bufprev = eof = 0; filename = argv[optind++]; fd = open(filename, 0, 0); if (fd < 0) { fprintf(stderr, "%s: %s: %s\n", prog, filename,#ifdef macintosh "???");#else sys_errlist[errno]);#endif macintosh error = 1; continue; } if (line_count = grep()) matches_found = 1; close(fd); if (count_lines) if (!no_filenames) printf("%s:%d\n", filename, line_count); else printf("%d\n", line_count); else if (list_files && line_count) printf("%s\n", filename); } else { if (line_count = grep()) matches_found = 1; if (count_lines) printf("%d\n", line_count); else if (list_files && line_count) printf("<stdin>\n"); } if (error) exit(ERROR); if (matches_found) exit(MATCHES_FOUND); exit(ES_FOUND);}/* Needed by the regexp routines. This could be fancier, especially when dealing with parallel regexps in files. */voidregerror(s) const char *s;{ fprintf(stderr, "%s: %s\n", prog, s); exit(ERROR);}/* bmg_setup() and bmg_search() adapted from: Boyer/Moore/Gosper-assisted 'egrep' search, with delta0 table as in original paper (CACM, October, 1977). No delta1 or delta2. According to experiment (Horspool, Soft. Prac. Exp., 1982), delta2 is of minimal practical value. However, to improve for worst case input, integrating the improved Galil strategies (Apostolico/Giancarlo, Siam. J. Comput., February 1986) deserves consideration. James A. Woods Copyleft (C) 1986, 1988 NASA Ames Research Center*/char *execute(r, begin, end, newline, count, try_backref) struct regexp *r; char *begin; char *end; int newline; int *count; int *try_backref;{ register char *p, *s; char *match; char *start = begin; char save; /* regexecute() sentinel */ int len; char *bmg_search(); if (!bmgexec) /* full automaton search */ return(regexecute(r, begin, end, newline, count, try_backref)); else { len = end - begin; while ((match = bmg_search((unsigned char *) start, len)) != NULL) { p = match; /* narrow search range to submatch line */ while (p > begin && *p != '\n') p--; s = match; while (s < end && *s != '\n') s++; s++; save = *s; *s = '\0'; match = regexecute(r, p, s, newline, count, try_backref); *s = save; if (match != NULL) return((char *) match); else { start = s; len = end - start; } } return(NULL); }}#include <ctype.h>int delta0[256];unsigned char cmap[256]; /* (un)folded characters */unsigned char pattern[5000];int patlen;char *bmg_search(buffer, buflen) unsigned char *buffer; int buflen;{ register unsigned char *k, *strend, *s, *buflim; register int t; int j; if (patlen > buflen) return NULL; buflim = buffer + buflen; if (buflen > patlen * 4) strend = buflim - patlen * 4; else strend = buffer; s = buffer; k = buffer + patlen - 1; for (;;) { /* The dreaded inner loop, revisited. */ while (k < strend && (t = delta0[*k])) { k += t; k += delta0[*k]; k += delta0[*k]; } while (k < buflim && delta0[*k]) ++k; if (k == buflim) break; j = patlen - 1; s = k; while (--j >= 0 && cmap[*--s] == pattern[j]) ; /* delta-less shortcut for literati, but short shrift for genetic engineers. */ if (j >= 0) k++; else /* submatch */ return ((char *)k); } return(NULL);}bmg_setup(pat, folded) /* compute "boyer-moore" delta table */ char *pat; int folded;{ /* ... HAKMEM lives ... */ int j; patlen = strlen(pat); if (folded) /* fold case while saving pattern */ for (j = 0; j < patlen; j++) pattern[j] = (isupper((int) pat[j]) ? (char) tolower((int) pat[j]) : pat[j]); else memcpy(pattern, pat, patlen); for (j = 0; j < 256; j++) { delta0[j] = patlen; cmap[j] = (char) j; /* could be done at compile time */ } for (j = 0; j < patlen - 1; j++) delta0[pattern[j]] = patlen - j - 1; delta0[pattern[patlen - 1]] = 0; if (folded) { for (j = 0; j < patlen - 1; j++) if (islower((int) pattern[j])) delta0[toupper((int) pattern[j])] = patlen - j - 1; if (islower((int) pattern[patlen - 1])) delta0[toupper((int) pattern[patlen - 1])] = 0; for (j = 'A'; j <= 'Z'; j++) cmap[j] = (char) tolower((int) j); }}#ifndef USG/* (groan) compatibility */char *strchr(s, c) char *s;{ return index(s, c);}char *strrchr(s, c) char *s;{ return rindex(s, c);}char *memcpy(d, s, n) char *d, *s;{ return bcopy(s, d, n);}#elsechar *index(s, c) char *s;{ return strchr(s, c);}char *bcopy(s, d, n) char *s, *d;{ return memcpy(d, s, n);}char *bzero(s, n) char *s;{ return memset(s, 0, n);}bcmp(s, t, n) char *s, *t;{ return memcmp(s, t, n);}#endif :MPW:MPW Tools:Tools with Source:gnu grep 1.5 ƒ:grep.make
1988 December 13 GREP(1)NAME grep, egrep - print lines matching a regular expressionSYNOPSIS grep [ -CVbchilnsvwx ] [ -num ] [ -AB num ] [ [ -e ] expr | -f file ] [ files ... ]DESCRIPTION Grep searches the files listed in the arguments (or standard input if no files are given) for all lines that contain a match for the given expr. If any lines match, they are printed. Also, if any matches were found, grep will exit with a status of 0, but if no matches were found it will exit with a status of 1. This is useful for building shell scripts that use grep as a condition for, for example, the if state- ment. When invoked as egrep the syntax of the expr is slightly different; See below.REGULAR EXPRESSIONS (grep) (egrep) (explanation) c c a single (non-meta) character matches itself. . . matches any single character except newline. \? ? postfix operator; preceeding item is optional. * * postfix operator; preceeding item 0 or more times. \+ + postfix operator; preceeding item 1 or more times. \| | infix operator; matches either argument. ^ ^ matches the empty string at the beginning of a line. $ $ matches the empty string at the end of a line. \< \< matches the empty string at the beginning of a word. 1GREP(1) 1988 December 13 \> \> matches the empty string at the end of a word. [chars] [chars] match any character in the given class; if the first character after [ is ^, match any character not in the given class; a range of charac- ters may be specified by first-last; for example, \W (below) is equivalent to the class [^A-Za-z0-9] \( \) ( ) parentheses are used to override operator precedence. \digit \digit \n matches a repeat of the text matched earlier in the regexp by the subexpression inside the nth opening parenthesis. \ \ any special character may be pre- ceded by a backslash to match it literally. (the following are for compatibility with GNU Emacs) \b \b matches the empty string at the edge of a word. \B \B matches the empty string if not at the edge of a word. \w \w matches word-constituent characters (letters & digits). \W \W matches characters that are not word-constituent. Operator precedence is (highest to lowest) ?, *, and +, con- catenation, and finally |. All other constructs are syntac- tically identical to normal characters. For the truly interested, the file dfa.c describes (and implements) the exact grammar understood by the parser.OPTIONS -A num print <num> lines of context after every matching line -B num print num lines of context before every matching line -C print 2 lines of context on each side of every match21988 December 13 GREP(1) -num print num lines of context on each side of every match -V print the version number on the diagnostic output -b print every match preceded by its byte offset -c print a total count of matching lines only -e expr search for expr; useful if expr begins with - -f file search for the expression contained in file -h don't display filenames on matches -i ignore case difference when comparing strings -l list files containing matches only -n print each match preceded by its line number -s run silently producing no output except error messages -v print only lines that contain no matches for the <expr> -w print only lines where the match is a complete word -x print only lines where the match is a whole lineSEE ALSO emacs(1), ed(1), sh(1), GNU Emacs ManualINCOMPATIBILITIES The following incompatibilities with UNIX grep exist: The context-dependent meaning of * is not quite the same (grep only). -b prints a byte offset instead of a block offset. The {m,n} construct of System V grep is not imple- mented.BUGS GNU e?grep has been thoroughly debugged and tested by several people over a period of several months; we think it's a reliable beast or we wouldn't distribute it. If by some fluke of the universe you discover a bug, send a detailed description (including options, regular expres- sions, and a copy of an input file that can reproduce it) to me, mike@wheaties.ai.mit.edu. 3GREP(1) 1988 December 13 There is also a newsgroup, gnu.utils.bug, for reporting FSF utility programs' bugs and fixes; but before reporting some- thing as a bug, please try to be sure that it really is a bug, not a misunderstanding or a deliberate feature. Also, include the version number of the utility program you are running in every bug report that you send in. Please do not send anything but bug reports to this newsgroup.AVAILABILITY GNU grep is free; anyone may redistribute copies of grep to anyone under the terms stated in the GNU General Public License, a copy of which may be found in each copy of GNU Emacs. See also the comment at the beginning of the source code file grep.c. Copies of GNU grep may sometimes be received packaged with distributions of Unix systems, but it is never included in the scope of any license covering those systems. Such inclusion violates the terms on which distribution is per- mitted. In fact, the primary purpose of the General Public License is to prohibit anyone from attaching any other res- trictions to redistribution of any of the Free Software Foundation programs.AUTHORS Mike Haertel wrote the deterministic regexp code and the bulk of the program. James A. Woods is responsible for the hybridized search strategy of using Boyer-Moore-Gosper fixed-string search as a filter before calling the general regexp matcher. Arthur David Olson contributed code that finds fixed strings for the aforementioned BMG search for a large class of regexps. Richard Stallman wrote the backtracking regexp matcher that is used for \fIdigit backreferences, as well as the getopt that is provided for 4.2BSD sites. The backtracking matcher was originally written for GNU Emacs. D. A. Gwyn wrote the C alloca emulation that is provided so System V machines can run this program. (Alloca is used only by RMS' backtracking matcher, and then only rarely, so there is no loss if your machine doesn't have a "real" alloca.) Scott Anderson and Henry Spencer designed the regression tests used in the "regress" script. Paul Placeway wrote the original version of this manual page.4 :MPW:MPW Tools:Tools with Source:gnu grep 1.5 ƒ:READ ME FIRST!!!
This is a port of gnu grep/egrep 1.5 to the MPW 3.1 environment. All source changes arebracketed by #ifdef macintosh directives. Send Mac specific bug reports to Mat Marcus atAppleLink D3870Internet lynx@belch.berkeley.edu Other gnu->mpw ports: ar bison compress flex gawk gnuchess gnu-go (in progress) grep/egrep libg++ (in progress) sedOther available unix ports: tar (standalone app) compress (standalone app) ### Contents 'READ ME FIRST!!!' #this file# these (non-gnu) files are useful in a wide variety of unix->mac porting efforts alloca.c #a c version of alloca (stack based malloc)# these files are useful in a wide variety of unix->mac porting efforts getopt.c regex.c regex.h# these are the grep specific files dfa.c # source code for Deterministic Finite Automaton (DFA) dfa.h egrep.make # mpw makefile for egrep grep.c # main source code for grep & egrep grep.make # mpw makefile for grep grep.man # user manual for grep and egrep # here is an 881/020 compiled verion of gnu egrep 1.2 egrep #compiled MPW 3.1 tool (requires 881/020) # the folder :tests: # mac versions of egrep test files (requires gawk) # run anderson.script and run spencer.script if you # have gawk and plenty of time to wait! # other unused unix files (included for completeness) README.cray README.sunos4 unixMakefile :MPW:MPW Tools:Tools with Source:gnu grep 1.5 ƒ:README
This README documents GNU e?grep version 1.5. All bugs reported forprevious versions have been fixed. I would like to emphasize: Pleasesend bug reports directly to me (mike@ai.mit.edu), *not* bug-gnu-utils.Changes needed to the makefile under various perversions of Unix aredescribed therein.If the type "char" is unsigned on your machine, you will have to fixthe definition of the macro SIGN_EXTEND_CHAR() in regex.c. A reasonabledefinition might be: #define SIGN_EXTEND_CHAR(c) ((c)>(char)127?(c)-256:(c))GNU e?grep is provided "as is" with no warranty. The exact termsunder which you may use and (re)distribute this program are detailedin a comment at the top of grep.c.GNU e?grep is based on a fast lazy-state deterministic matcher (abouttwice as fast as stock Unix egrep) hybridized with a Boyer-Moore-Gospersearch for a fixed string that eliminates impossible text from beingconsidered by the full regexp matcher without necessarily having tolook at every character. The result is typically many times fasterthan Unix grep or egrep. (Regular expressions containing backreferencingmay run more slowly, however.)GNU e?grep attempts, as closely as possible, to understand compatiblythe regexp syntaxes of the Unix programs it replaces. The following tabledetails the various special characters understood in both the grep andegrep incarnations:(grep) (egrep) (explanation) . . matches any single character except newline \? ? postfix operator; preceeding item is optional * * postfix operator; preceeding item 0 or more times \+ + postfix operator; preceeding item 1 or more times \| | infix operator; matches either argument ^ ^ matches the empty string at the beginning of a line $ $ matches the empty string at the end of a line \< \< matches the empty string at the beginning of a word \> \> matches the empty string at the end of a word [chars] [chars] match any character in the given class; if the first character after [ is ^, match any character not in the given class; a range of characters may be specified by <first>-<last>; for example, \W (below) is equivalent to the class [^A-Za-z0-9] \( \) ( ) parentheses are used to override operator precedence \<1-9> \<1-9> \<n> matches a repeat of the text matched earlier in the regexp by the subexpression inside the nth opening parenthesis \ \ any special character may be preceded by a backslash to match it literally(the following are for compatibility with GNU Emacs) \b \b matches the empty string at the edge of a word \B \B matches the empty string if not at the edge of a word \w \w matches word-constituent characters (letters & digits) \W \W matches characters that are not word-constituentOperator precedence is (highest to lowest) ?, *, and +, concatenation,and finally |. All other constructs are syntactically identical tonormal characters. For the truly interested, a comment in dfa.c describesthe exact grammar understood by the parser.GNU e?grep understands the following command line options: -A <num> print <num> lines of context after every matching line -B <num> print <num> lines of context before every matching line -C print 2 lines of context on each side of every match -<num> print <num> lines of context on each side -V print the version number on stderr -b print every match preceded by its byte offset -c print a total count of matching lines only -e <expr> search for <expr>; useful if <expr> begins with - -f <file> take <expr> from the given <file> -h don't display filenames on matches -i ignore case difference when comparing strings -l list files containing matches only -n print each match preceded by its line number -s run silently producing no output except error messages -v print only lines that contain no matches for the <expr> -w print only lines where the match is a complete word -x print only lines where the match is a whole lineThe options understood by GNU e?grep are meant to be (nearly) compatiblewith both the BSD and System V versions of grep and egrep.The following incompatibilities with other versions of grep exist: the context-dependent meaning of * is not quite the same (grep only) -b prints a byte offset instead of a block offset the \{m,n\} construct of System V grep is not implementedGNU e?grep has been thoroughly debugged and tested by several peopleover a period of several months; we think it's a reliable beast or wewouldn't distribute it. If by some fluke of the universe you discovera bug, send a detailed description (including options, regularexpressions, and a copy of an input file that can reproduce it) to me,mike@wheaties.ai.mit.edu.GNU e?grep is brought to you by the efforts of several people: Mike Haertel wrote the deterministic regexp code and the bulk of the program. James A. Woods is responsible for the hybridized search strategy of using Boyer-Moore-Gosper fixed-string search as a filter before calling the general regexp matcher. Arthur David Olson contributed code that finds fixed strings for the aforementioned BMG search for a large class of regexps. Richard Stallman wrote the backtracking regexp matcher that is used for \<digit> backreferences, as well as the getopt that is provided for 4.2BSD sites. The backtracking matcher was originally written for GNU Emacs. D. A. Gwyn wrote the C alloca emulation that is provided so System V machines can run this program. (Alloca is used only by RMS' backtracking matcher, and then only rarely, so there is no loss if your machine doesn't have a "real" alloca.) Scott Anderson and Henry Spencer designed the regression tests used in the "regress" script. Paul Placeway wrote the manual page, based on this README.If you are interested in improving this program, you may wish to tryany of the following:1. Make backreferencing \<digit> faster. Right now, backreferencing is handled by calling the Emacs backtracking matcher to verify the partial match. This is slow; if the DFA routines could handle backreferencing themselves a speedup on the order of three to four times might occur in those cases where the backtracking matcher is called to verify nearly every line. Also, some portability problems due to the inclusion of the emacs matcher would be solved because it could then be eliminated. Note that expressions with backreferencing are not true regular expressions, and thus are not equivalent to any DFA. So this is hard.2. There is a bug in the backtracking matcher, regex.c, such that the | operator is not properly commutative. Let x and y be arbitrary regular expressions, and suppose both x and y have matches at some point in the target text. Then the regexp x|y should select the longest of the two matches. Wbacktracking matcher, if the first match succeeds it does not even try the second, even though the second may be a longer match. This is obviously of no concern for grep, which does not care exactly where or how long a match is, so long as it knows it is there. On the other hand, the backtracking matcher is used in GNU AWK, wherein its behavior can only be considered a bug.3. Handle POSIX style regexps. I'm not sure if this could be called an improvement; some of the things on regexps in the POSIX draft I have seen are pretty sickening. But it would be useful in the interests of conforming to the standard. :MPW:MPW Tools:Tools with Source:gnu grep 1.5 ƒ:README.cray
(Message inbox:135)Date: Mon, 17 Oct 88 16:53:33 PDTTo: mike@wheaties.ai.mit.educc: darin%pioneer@eos.arc.nasa.gov, luzmoor@violet.berkeley.eduFrom: James A. Woods <jaw@eos.arc.nasa.gov>Subject: README.cray for GNU e?grepI just sent this out to comp.unix.cray:-------------------------------------------------------------------From: jaw@eos.UUCP (James A. Woods)Newsgroups: comp.unix.craySubject: GNU e?grep on Cray machinesMessage-ID: <1750@eos.UUCP>Date: 17 Oct 88 23:47:29 GMTOrganization: NASA Ames Research Center, CaliforniaLines: 66# "What comes after silicon? Oh, gallium arsenide, I'd guess. And after that, there's a thing called indium phosphide." -- Seymour Cray, Datamation interview, circa 1980 Now that most Cray software development is done on Crays themselves, thanks to Unix, GNU e?grep should come in handy. Of course, if you'rescanning GENBANK for the Human Genome Project at 10 MB/second (the rawX/MP Unix I/O rate), you really do need the speed. Sample, from one of the Ames Cray 2 machines: stokes> time ./egrep astrian web2 # GNU egrep alabastrian Lancastrian Zoroastrian Zoroastrianism 0.5980u 0.0772s 0:01 35% stokes> time /usr/bin/egrep astrian web2 # ATT egrep alabastrian Lancastrian Zoroastrian Zoroastrianism 7.6765u 0.1373s 0:15 49%(web2 is a 2.4 MB wordlist, standard on BSD Unix.) To bring up GNU E?GREP, ftp Mike Haertel's version 1.1 package from'prep.ai.mit.edu' or 'ames.arc.nasa.gov'. Mention -DUSG in the Makefile,and specify #define SIGN_EXTEND_CHAR(c) ((c)>(char)127?(c)-256:(c))in regex.c. [Cray characters, like MIPS chars, are unsigned, but thecompiler won't allow ... #define SIGN_EXTEND_CHAR(c) ((signed char) (c))] However, at least on the Cray 2, there's a compiler bug involving theincrement operator in complex expressions, which requires the followingmodification (also in regex.c):change m->elems[m->nelem++].constraint |= s2->elems[j++].constraint;to m->elems[m->nelem].constraint |= s2->elems[j].constraint; m->nelem++; j++;Thanks go to Darin Okuyama of NASA ARC for providing this workaround.-- James A. Woods (ames!jaw) NASA Ames Research CenterP.S. Though Crays are not at their best pushing bytes, the timing differenceis even more exaggerated with heavier regexpr processing, to wit: time ./egrep -i 'as.*Trian' web2 ... 0.7677u 0.0769s 0:01 44%vs. time /usr/bin/egrep -i 'as.*Trian' web2 ... 16.1327u 0.1379s 0:32 49%which is a mite unfair given a known System 5 egrep -i gaffe. You getextra credit for vectorizing the inner loop of the Boyer/Moore/Gospercode, though changing all chars to ints might help also. :MPW:MPW Tools:Tools with Source:gnu grep 1.5 ƒ:README.sunos4
[ N.B. This bug strikes on a Sun 3 running SunOS 4 with the cc -O4 option as well as on the sparc. -Mike ]Date: Fri, 24 Feb 89 15:36:40 -0600To: mike@wheaties.ai.mit.eduFrom: Dave Cohrs <dave@cs.wisc.edu>Subject: bug + fix in gnu grep 1.2 (from prep.ai.mit.edu)I tried installing the GNU grep 1.2 on a Sun4 running 4.0.1 and"Spencer test #36" failed. After some experimenting, I found andfixed the bug. Well, actually, the bug in the the C compiler, butI managed a workaround.Description:The Sun4 4.0.1 C compiler with -O doesn't generate the correct forstatements of the form if("string") x; else y;To be exact, "y;" gets executed, while "x;" should. This causes the#define FETCH() to fail for test #36.Fix:In an #ifdef sparc in dfa.c, I made two versions of FETCH, FETCH0() andthe regular FETCH(). The former takes only one argument, the latterexpects its 2nd argument to contain a non-nil string. This removesthe need to test the constant strings, and the compiler bug isn'texercised. I then changed the one instance of FETCH() with a nilsecond argument to be FETCH0() instead.dave cohrs===================================================================RCS file: RCS/dfa.c,vretrieving revision 1.1diff -c -r1.1 dfa.c*** /tmp/,RCSt1a05930 Fri Feb 24 15:32:33 1989--- dfa.c Fri Feb 24 15:23:34 1989****************** 285,293 ****--- 285,315 ---- is turned off). */ /* Note that characters become unsigned here. */+ #ifdef sparc+ /*+ * Sun4 4.0.1 C compiler can't compare constant strings correctly.+ * e.g. if("test") { x; } else { y; }+ * the compiler will not generate code to execute { x; }, but+ * executes { y; } instead.+ */+ #define FETCH0(c) \+ { \+ if (! lexleft) \+ return _END; \+ (c) = (unsigned char) *lexptr++; \+ --lexleft; \+ } #define FETCH(c, eoferr) \ { \ if (! lexleft) \+ regerror(eoferr); \+ (c) = (unsigned char) *lexptr++; \+ --lexleft; \+ }+ #else+ #define FETCH(c, eoferr) \+ { \+ if (! lexleft) \ if (eoferr) \ regerror(eoferr); \ else \****************** 295,300 ****--- 317,323 ---- (c) = (unsigned char) *lexptr++; \ --lexleft; \ }+ #endif sparc static _token lex()****************** 303,309 ****--- 326,336 ---- int invert; _charset cset; + #ifdef sparc+ FETCH0(c);+ #else FETCH(c, (char *) 0);+ #endif sparc switch (c) { case '^': :MPW:MPW Tools:Tools with Source:gnu grep 1.5 ƒ:regex.c
/* Extended regular expression matching and search library. Copyright (C) 1985, 1989 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. In other words, you are welcome to use, share and improve this program. You are forbidden to forbid anyone else to use, share and improve what you give them. Help stamp out software-hoarding! *//* To test, compile with -Dtest. This Dtestable feature turns this into a self-contained program which reads a pattern, describes how it compiles, then reads a string and searches for it. */#ifdef emacs/* The `emacs' switch turns on certain special matching commands that make sense only in emacs. */#include "config.h"#include "lisp.h"#include "buffer.h"#include "syntax.h"#else /* not emacs */#ifdef USG#define bcopy(s,d,n) memcpy((d),(s),(n))#define bcmp(s1,s2,n) memcmp((s1),(s2),(n))#define bzero(s,n) memset((s),0,(n))#endif/* Make alloca work the best possible way. */#ifdef __GNUC__#define alloca __builtin_alloca#else#ifdef sparc#include <alloca.h>#endif#endif/* * Define the syntax stuff, so we can do the \<...\> things. */#ifndef Sword /* must be non-zero in some of the tests below... */#define Sword 1#endif#define SYNTAX(c) re_syntax_table[c]#ifdef SYNTAX_TABLEchar *re_syntax_table;#elsestatic char re_syntax_table[256];static voidinit_syntax_once (){ register int c; static int done = 0; if (done) return; bzero (re_syntax_table, sizeof re_syntax_table); for (c = 'a'; c <= 'z'; c++) re_syntax_table[c] = Sword; for (c = 'A'; c <= 'Z'; c++) re_syntax_table[c] = Sword; for (c = '0'; c <= '9'; c++) re_syntax_table[c] = Sword; done = 1;}#endif /* SYNTAX_TABLE */#endif /* not emacs */#include "regex.h"/* Number of failure points to allocate space for initially, when matching. If this number is exceeded, more space is allocated, so it is not a hard limit. */#ifndef NFAILURES#define NFAILURES 80#endif /* NFAILURES *//* width of a byte in bits */#define BYTEWIDTH 8#ifndef SIGN_EXTEND_CHAR#define SIGN_EXTEND_CHAR(x) (x)#endif static int obscure_syntax = 0;/* Specify the precise syntax of regexp for compilation. This provides for compatibility for various utilities which historically have different, incompatible syntaxes. The argument SYNTAX is a bit-mask containing the two bits RE_NO_BK_PARENS and RE_NO_BK_VBAR. */intre_set_syntax (syntax){ int ret; ret = obscure_syntax; obscure_syntax = syntax; return ret;} /* re_compile_pattern takes a regular-expression string and converts it into a buffer full of byte commands for matching. PATTERN is the address of the pattern string SIZE is the length of it. BUFP is a struct re_pattern_buffer * which points to the info on where to store the byte commands. This structure contains a char * which points to the actual space, which should have been obtained with malloc. re_compile_pattern may use realloc to grow the buffer space. The number of bytes of commands can be found out by looking in the struct re_pattern_buffer that bufp pointed to, after re_compile_pattern returns.*/#define PATPUSH(ch) (*b++ = (char) (ch))#define PATFETCH(c) \ {if (p == pend) goto end_of_pattern; \ c = * (unsigned char *) p++; \ if (translate) c = translate[c]; }#define PATFETCH_RAW(c) \ {if (p == pend) goto end_of_pattern; \ c = * (unsigned char *) p++; }#define PATUNFETCH p--#define EXTEND_BUFFER \ { char *old_buffer = bufp->buffer; \ if (bufp->allocated == (1<<16)) goto too_big; \ bufp->allocated *= 2; \ if (bufp->allocated > (1<<16)) bufp->allocated = (1<<16); \ if (!(bufp->buffer = (char *) realloc (bufp->buffer, bufp->allocated))) \ goto memory_exhausted; \ c = bufp->buffer - old_buffer; \ b += c; \ if (fixup_jump) \ fixup_jump += c; \ if (laststart) \ laststart += c; \ begalt += c; \ if (pending_exact) \ pending_exact += c; \ }static int store_jump (), insert_jump ();char *re_compile_pattern (pattern, size, bufp) char *pattern; int size; struct re_pattern_buffer *bufp;{ register char *b = bufp->buffer; register char *p = pattern; char *pend = pattern + size; register unsigned c, c1; char *p1; unsigned char *translate = (unsigned char *) bufp->translate; /* address of the count-byte of the most recently inserted "exactn" command. This makes it possible to tell whether a new exact-match character can be added to that command or requires a new "exactn" command. */ char *pending_exact = 0; /* address of the place where a forward-jump should go to the end of the containing expression. Each alternative of an "or", except the last, ends with a forward-jump of this sort. */ char *fixup_jump = 0; /* address of start of the most recently finished expression. This tells postfix * where to find the start of its operand. */ char *laststart = 0; /* In processing a repeat, 1 means zero matches is allowed */ char zero_times_ok; /* In processing a repeat, 1 means many matches is allowed */ char many_times_ok; /* address of beginning of regexp, or inside of last \( */ char *begalt = b; /* Stack of information saved by \( and restored by \). Four stack elements are pushed by each \(: First, the value of b. Second, the value of fixup_jump. Third, the value of regnum. Fourth, the value of begalt. */ int stackb[40]; int *stackp = stackb; int *stacke = stackb + 40; int *stackt; /* Counts \('s as they are encountered. Remembered for the matching \), where it becomes the "register number" to put in the stop_memory command */ int regnum = 1; bufp->fastmap_accurate = 0;#ifndef emacs#ifndef SYNTAX_TABLE /* * Initialize the syntax table. */ init_syntax_once();#endif#endif if (bufp->allocated == 0) { bufp->allocated = 28; if (bufp->buffer) /* EXTEND_BUFFER loses when bufp->allocated is 0 */ bufp->buffer = (char *) realloc (bufp->buffer, 28); else /* Caller did not allocate a buffer. Do it for him */ bufp->buffer = (char *) malloc (28); if (!bufp->buffer) goto memory_exhausted; begalt = b = bufp->buffer; } while (p != pend) { if (b - bufp->buffer > bufp->allocated - 10) /* Note that EXTEND_BUFFER clobbers c */ EXTEND_BUFFER; PATFETCH (c); switch (c) { case '$': if (obscure_syntax & RE_TIGHT_VBAR) { if (! (obscure_syntax & RE_CONTEXT_INDEP_OPS) && p != pend) goto normal_char; /* Make operand of last vbar end before this `$'. */ if (fixup_jump) store_jump (fixup_jump, jump, b); fixup_jump = 0; PATPUSH (endline); break; } /* $ means succeed if at end of line, but only in special contexts. If randomly in the middle of a pattern, it is a normal character. */ if (p == pend || *p == '\n' || (obscure_syntax & RE_CONTEXT_INDEP_OPS) || (obscure_syntax & RE_NO_BK_PARENS ? *p == ')' : *p == '\\' && p[1] == ')') || (obscure_syntax & RE_NO_BK_VBAR ? *p == '|' : *p == '\\' && p[1] == '|')) { PATPUSH (endline); break; } goto normal_char; case '^': /* ^ means succeed if at beg of line, but only if no preceding pattern. */ if (laststart && p[-2] != '\n' && ! (obscure_syntax & RE_CONTEXT_INDEP_OPS)) goto normal_char; if (obscure_syntax & RE_TIGHT_VBAR) { if (p != pattern + 1 && ! (obscure_syntax & RE_CONTEXT_INDEP_OPS)) goto normal_char; PATPUSH (begline); begalt = b; } else PATPUSH (begline); break; case '+': case '?': if (obscure_syntax & RE_BK_PLUS_QM) goto normal_char; handle_plus: case '*': /* If there is no previous pattern, char not special. */ if (!laststart && ! (obscure_syntax & RE_CONTEXT_INDEP_OPS)) goto normal_char; /* If there is a sequence of repetition chars, collapse it down to equivalent to just one. */ zero_times_ok = 0; many_times_ok = 0; while (1) { zero_times_ok |= c != '+'; many_times_ok |= c != '?'; if (p == pend) break; PATFETCH (c); if (c == '*') ; else if (!(obscure_syntax & RE_BK_PLUS_QM) && (c == '+' || c == '?')) ; else if ((obscure_syntax & RE_BK_PLUS_QM) && c == '\\') { int c1; PATFETCH (c1); if (!(c1 == '+' || c1 == '?')) { PATUNFETCH; PATUNFETCH; break; } c = c1; } else { PATUNFETCH; break; } } /* Star, etc. applied to an empty pattern is equivalent to an empty pattern. */ if (!laststart) break; /* Now we know whether 0 matches is allowed, and whether 2 or more matches is allowed. */ if (many_times_ok) { /* If more than one repetition is allowed, put in a backward jump at the end. */ store_jump (b, maybe_finalize_jump, laststart - 3); b += 3; } insert_jump (on_failure_jump, laststart, b + 3, b); pending_exact = 0; b += 3; if (!zero_times_ok) { /* At least one repetition required: insert before the loop a skip over the initial on-failure-jump instruction */ insert_jump (dummy_failure_jump, laststart, laststart + 6, b); b += 3; } break; case '.': laststart = b; PATPUSH (anychar); break; case '[': while (b - bufp->buffer > bufp->allocated - 3 - (1 << BYTEWIDTH) / BYTEWIDTH) /* Note that EXTEND_BUFFER clobbers c */ EXTEND_BUFFER; laststart = b; if (*p == '^') PATPUSH (charset_not), p++; else PATPUSH (charset); p1 = p; PATPUSH ((1 << BYTEWIDTH) / BYTEWIDTH); /* Clear the whole map */ bzero (b, (1 << BYTEWIDTH) / BYTEWIDTH); /* Read in characters and ranges, setting map bits */ while (1) { PATFETCH (c); if (c == ']' && p != p1 + 1) break; if (*p == '-' && p[1] != ']') { PATFETCH (c1); PATFETCH (c1); while (c <= c1) b[c / BYTEWIDTH] |= 1 << (c % BYTEWIDTH), c++; } else { b[c / BYTEWIDTH] |= 1 << (c % BYTEWIDTH); } } /* Discard any bitmap bytes that are all 0 at the end of the map. Decrement the map-length byte too. */ while ((int) b[-1] > 0 && b[b[-1] - 1] == 0) b[-1]--; b += b[-1]; break; case '(': if (! (obscure_syntax & RE_NO_BK_PARENS)) goto normal_char; else goto handle_open; case ')': if (! (obscure_syntax & RE_NO_BK_PARENS)) goto normal_char; else goto handle_close; case '\n': if (! (obscure_syntax & RE_NEWLINE_OR)) goto normal_char; else goto handle_bar; case '|': if (! (obscure_syntax & RE_NO_BK_VBAR)) goto normal_char; else goto handle_bar; case '\\': if (p == pend) goto invalid_pattern; PATFETCH_RAW (c); switch (c) { case '(': if (obscure_syntax & RE_NO_BK_PARENS) goto normal_backsl; handle_open: if (stackp == stacke) goto nesting_too_deep; if (regnum < RE_NREGS) { PATPUSH (start_memory); PATPUSH (regnum); } *stackp++ = b - bufp->buffer; *stackp++ = fixup_jump ? fixup_jump - bufp->buffer + 1 : 0; *stackp++ = regnum++; *stackp++ = begalt - bufp->buffer; fixup_jump = 0; laststart = 0; begalt = b; break; case ')': if (obscure_syntax & RE_NO_BK_PARENS) goto normal_backsl; handle_close: if (stackp == stackb) goto unmatched_close; begalt = *--stackp + bufp->buffer; if (fixup_jump) store_jump (fixup_jump, jump, b); if (stackp[-1] < RE_NREGS) { PATPUSH (stop_memory); PATPUSH (stackp[-1]); } stackp -= 2; fixup_jump = 0; if (*stackp) fixup_jump = *stackp + bufp->buffer - 1; laststart = *--stackp + bufp->buffer; break; case '|': if (obscure_syntax & RE_NO_BK_VBAR) goto normal_backsl; handle_bar: insert_jump (on_failure_jump, begalt, b + 6, b); pending_exact = 0; b += 3; if (fixup_jump) store_jump (fixup_jump, jump, b); fixup_jump = b; b += 3; laststart = 0; begalt = b; break;#ifdef emacs case '=': PATPUSH (at_dot); break; case 's': laststart = b; PATPUSH (syntaxspec); PATFETCH (c); PATPUSH (syntax_spec_code[c]); break; case 'S': laststart = b; PATPUSH (notsyntaxspec); PATFETCH (c); PATPUSH (syntax_spec_code[c]); break;#endif /* emacs */ case 'w': laststart = b; PATPUSH (wordchar); break; case 'W': laststart = b; PATPUSH (notwordchar); break; case '<': PATPUSH (wordbeg); break; case '>': PATPUSH (wordend); break; case 'b': PATPUSH (wordbound); break; case 'B': PATPUSH (notwordbound); break; case '`': PATPUSH (begbuf); break; case '\'': PATPUSH (endbuf); break; case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': c1 = c - '0'; if (c1 >= regnum) goto normal_char; for (stackt = stackp - 2; stackt > stackb; stackt -= 4) if (*stackt == c1) goto normal_char; laststart = b; PATPUSH (duplicate); PATPUSH (c1); break; case '+': case '?': if (obscure_syntax & RE_BK_PLUS_QM) goto handle_plus; default: normal_backsl: /* You might think it would be useful for \ to mean not to translate; but if we don't translate it it will never match anything. */ if (translate) c = translate[c]; goto normal_char; } break; default: normal_char: if (!pending_exact || pending_exact + *pending_exact + 1 != b || *pending_exact == 0177 || *p == '*' || *p == '^' || ((obscure_syntax & RE_BK_PLUS_QM) ? *p == '\\' && (p[1] == '+' || p[1] == '?') : (*p == '+' || *p == '?'))) { laststart = b; PATPUSH (exactn); pending_exact = b; PATPUSH (0); } PATPUSH (c); (*pending_exact)++; } } if (fixup_jump) store_jump (fixup_jump, jump, b); if (stackp != stackb) goto unmatched_open; bufp->used = b - bufp->buffer; return 0; invalid_pattern: return "Invalid regular expression"; unmatched_open: return "Unmatched \\("; unmatched_close: return "Unmatched \\)"; end_of_pattern: return "Premature end of regular expression"; nesting_too_deep: return "Nesting too deep"; too_big: return "Regular expression too big"; memory_exhausted: return "Memory exhausted";}/* Store where `from' points a jump operation to jump to where `to' points. `opcode' is the opcode to store. */static intstore_jump (from, opcode, to) char *from, *to; char opcode;{ from[0] = opcode; from[1] = (to - (from + 3)) & 0377; from[2]
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:gnu grep 1.5 ƒ:regex.c
+++++ Continued from previous card +++++
= (to - (from + 3)) >> 8;}/* Open up space at char FROM, and insert there a jump to TO. CURRENT_END gives te end of the storage no in use, so we know how much data to copy up. OP is the opcode of the jump to insert. If you call this function, you must zero out pending_exact. */static intinsert_jump (op, from, to, current_end) char op; char *from, *to, *current_end;{ register char *pto = current_end + 3; register char *pfrom = current_end; while (pfrom != from) *--pto = *--pfrom; store_jump (from, op, to);} /* Given a pattern, compute a fastmap from it. The fastmap records which of the (1 << BYTEWIDTH) possible characters can start a string that matches the pattern. This fastmap is used by re_search to skip quickly over totally implausible text. The caller must supply the address of a (1 << BYTEWIDTH)-byte data area as bufp->fastmap. The other components of bufp describe the pattern to be used. */voidre_compile_fastmap (bufp) struct re_pattern_buffer *bufp;{ unsigned char *pattern = (unsigned char *) bufp->buffer; int size = bufp->used; register char *fastmap = bufp->fastmap; register unsigned char *p = pattern; register unsigned char *pend = pattern + size; register int j, k; unsigned char *translate = (unsigned char *) bufp->translate; unsigned char *stackb[NFAILURES]; unsigned char **stackp = stackb; bzero (fastmap, (1 << BYTEWIDTH)); bufp->fastmap_accurate = 1; bufp->can_be_null = 0; while (p) { if (p == pend) { bufp->can_be_null = 1; break; }#ifdef SWITCH_ENUM_BUG switch ((int) ((enum regexpcode) *p++))#else switch ((enum regexpcode) *p++)#endif { case exactn: if (translate) fastmap[translate[p[1]]] = 1; else fastmap[p[1]] = 1; break; case begline: case before_dot: case at_dot: case after_dot: case begbuf: case endbuf: case wordbound: case notwordbound: case wordbeg: case wordend: continue; case endline: if (translate) fastmap[translate['\n']] = 1; else fastmap['\n'] = 1; if (bufp->can_be_null != 1) bufp->can_be_null = 2; break; case finalize_jump: case maybe_finalize_jump: case jump: case dummy_failure_jump: bufp->can_be_null = 1; j = *p++ & 0377; j += SIGN_EXTEND_CHAR (*(char *)p) << 8; p += j + 1; /* The 1 compensates for missing ++ above */ if (j > 0) continue; /* Jump backward reached implies we just went through the body of a loop and matched nothing. Opcode jumped to should be an on_failure_jump. Just treat it like an ordinary jump. For a * loop, it has pushed its failure point already; if so, discard that as redundant. */ if ((enum regexpcode) *p != on_failure_jump) continue; p++; j = *p++ & 0377; j += SIGN_EXTEND_CHAR (*(char *)p) << 8; p += j + 1; /* The 1 compensates for missing ++ above */ if (stackp != stackb && *stackp == p) stackp--; continue; case on_failure_jump: j = *p++ & 0377; j += SIGN_EXTEND_CHAR (*(char *)p) << 8; p++; *++stackp = p + j; continue; case start_memory: case stop_memory: p++; continue; case duplicate: bufp->can_be_null = 1; fastmap['\n'] = 1; case anychar: for (j = 0; j < (1 << BYTEWIDTH); j++) if (j != '\n') fastmap[j] = 1; if (bufp->can_be_null) return; /* Don't return; check the alternative paths so we can set can_be_null if appropriate. */ break; case wordchar: for (j = 0; j < (1 << BYTEWIDTH); j++) if (SYNTAX (j) == Sword) fastmap[j] = 1; break; case notwordchar: for (j = 0; j < (1 << BYTEWIDTH); j++) if (SYNTAX (j) != Sword) fastmap[j] = 1; break;#ifdef emacs case syntaxspec: k = *p++; for (j = 0; j < (1 << BYTEWIDTH); j++) if (SYNTAX (j) == (enum syntaxcode) k) fastmap[j] = 1; break; case notsyntaxspec: k = *p++; for (j = 0; j < (1 << BYTEWIDTH); j++) if (SYNTAX (j) != (enum syntaxcode) k) fastmap[j] = 1; break;#endif /* emacs */ case charset: for (j = *p++ * BYTEWIDTH - 1; j >= 0; j--) if (p[j / BYTEWIDTH] & (1 << (j % BYTEWIDTH))) { if (translate) fastmap[translate[j]] = 1; else fastmap[j] = 1; } break; case charset_not: /* Chars beyond end of map must be allowed */ fop * BYTEWIDTH; j < (1 << BYTEWIDTH); j++) if (translate) fastmap[translate[j]] = 1; else fastmap[j] = 1; for (j = *p++ * BYTEWIDTH - 1; j >= 0; j--) if (!(p[j / BYTEWIDTH] & (1 << (j % BYTEWIDTH)))) { if (translate) fastmap[translate[j]] = 1; else fastmap[j] = 1; } break; } /* Get here means we have successfully found the possible starting characters of one path of the pattern. We need not follow this path any farther. Instead, look at the next alternative remembered in the stack. */ if (stackp != stackb) p = *stackp--; else break; }} /* Like re_search_2, below, but only one string is specified. */intre_search (pbufp, string, size, startpos, range, regs) struct re_pattern_buffer *pbufp; char *string; int size, startpos, range; struct re_registers *regs;{ return re_search_2 (pbufp, 0, 0, string, size, startpos, range, regs, size);}/* Like re_match_2 but tries first a match starting at index STARTPOS, then at STARTPOS + 1, and so on. RANGE is the number of places to try before giving up. If RANGE is negative, the starting positions tried are STARTPOS, STARTPOS - 1, etc. It is up to the caller to make sure that range is not so large as to take the starting position outside of the input strings.The value returned is the position at which the match was found, or -1 if no match was found, or -2 if error (such as failure stack overflow). */intre_search_2 (pbufp, string1, size1, string2, size2, startpos, range, regs, mstop) struct re_pattern_buffer *pbufp; char *string1, *string2; int size1, size2; int startpos; register int range; struct re_registers *regs; int mstop;{ register char *fastmap = pbufp->fastmap; register unsigned char *translate = (unsigned char *) pbufp->translate; int total = size1 + size2; int val; /* Update the fastmap now if not correct already */ if (fastmap && !pbufp->fastmap_accurate) re_compile_fastmap (pbufp); /* Don't waste time in a long search for a pattern that says it is anchored. */ if (pbufp->used > 0 && (enum regexpcode) pbufp->buffer[0] == begbuf && range > 0) { if (startpos > 0) return -1; else range = 1; } while (1) { /* If a fastmap is supplied, skip quickly over characters that cannot possibly be the start of a match. Note, however, that if the pattern can possibly match the null string, we must test it at each starting point so that we take the first null string we get. */ if (fastmap && startpos < total && pbufp->can_be_null != 1) { if (range > 0) { register int lim = 0; register unsigned char *p; int irange = range; if (startpos < size1 && startpos + range >= size1) lim = range - (size1 - startpos); p = ((unsigned char *) &(startpos >= size1 ? string2 - size1 : string1)[startpos]); if (translate) { while (range > lim && !fastmap[translate[*p++]]) range--; } else { while (range > lim && !fastmap[*p++]) range--; } startpos += irange - range; } else { register unsigned char c; if (startpos >= size1) c = string2[startpos - size1]; else c = string1[startpos]; c &= 0xff; if (translate ? !fastmap[translate[c]] : !fastmap[c]) goto advance; } } if (range >= 0 && startpos == total && fastmap && pbufp->can_be_null == 0) return -1; val = re_match_2 (pbufp, string1, size1, string2, size2, startpos, regs, mstop); if (0 <= val) { if (val == -2) return -2; return startpos; }#ifdef C_ALLOCA alloca (0);#endif /* C_ALLOCA */ advance: if (!range) break; if (range > 0) range--, startpos++; else range++, startpos--; } return -1;} #ifndef emacs /* emacs never uses this */intre_match (pbufp, string, size, pos, regs) struct re_pattern_buffer *pbufp; char *string; int size, pos; struct re_registers *regs;{ return re_match_2 (pbufp, 0, 0, string, size, pos, regs, size);}#endif /* emacs *//* Maximum size of failure stack. Beyond this, overflow is an error. */int re_max_failures = 2000;static int bcmp_translate();/* Match the pattern described by PBUFP against data which is the virtual concatenation of STRING1 and STRING2. SIZE1 and SIZE2 are the sizes of the two data strings. Start the match at position POS. Do not consider matching past the position MSTOP. If pbufp->fastmap is nonzero, then it had better be up to date. The reason that the data to match are specified as two components which are to be regarded as concatenated is so this function can be used directly on the contents of an Emacs buffer. -1 is returned if there is no match. -2 is returned if there is an error (such as match stack overflow). Otherwise the value is the length of the substring which was matched. */intre_match_2 (pbufp, string1, size1, string2, size2, pos, regs, mstop) struct re_pattern_buffer *pbufp; unsigned char *string1, *string2; int size1, size2; int pos; struct re_registers *regs; int mstop;{ register unsigned char *p = (unsigned char *) pbufp->buffer; register unsigned char *pend = p + pbufp->used; /* End of first string */ unsigned char *end1; /* End of second string */ unsigned char *end2; /* Pointer just past last char to consider matching */ unsigned char *end_match_1, *end_match_2; register unsigned char *d, *dend; register int mcnt; unsigned char *translate = (unsigned char *) pbufp->translate; /* Failure point stack. Each place that can handle a failure further down the line pushes a failure point on this stack. It consists of two char *'s. The first one pushed is where to resume scanning the pattern; the second pushed is where to resume scanning the strings. If the latter is zero, the failure point is a "dummy". If a failure happens and the innermost failure point is dormant, it discards that failure point and tries the next one. */ unsigned char *initial_stack[2 * NFAILURES]; unsigned char **stackb = initial_stack; unsigned char **stackp = stackb, **stacke = &stackb[2 * NFAILURES]; /* Information on the "contents" of registers. These are pointers into the input strings; they record just what was matched (on this attempt) by some part of the pattern. The start_memory command stores the start of a register's contents and the stop_memory command stores the end. At that point, regstart[regnum] points to the first character in the register, regend[regnum] points to the first character beyond the end of the register, regstart_seg1[regnum] is true iff regstart[regnum] points into string1, and regend_seg1[regnum] is true iff regend[regnum] points into string1. */ unsigned char *regstart[RE_NREGS]; unsigned char *regend[RE_NREGS]; unsigned char regstart_seg1[RE_NREGS], regend_seg1[RE_NREGS]; /* Set up pointers to ends of strings. Don't allow the second string to be empty unless both are empty. */ if (!size2) { string2 = string1; size2 = size1; string1 = 0; size1 = 0; } end1 = string1 + size1; end2 = string2 + size2; /* Compute where to stop matching, within the two strings */ if (mstop <= size1) { end_match_1 = string1 + mstop; end_match_2 = string2; } else { end_match_1 = end1; end_match_2 = string2 + mstop - size1; } /* Initialize \) text positions to -1 to mark ones that no \( or \) has been seen for. */ for (mcnt = 0; mcnt < sizeof (regend) / sizeof (*regend); mcnt++) regend[mcnt] = (unsigned char *) -1; /* `p' scans through the pattern as `d' scans through the data. `dend' is the end of the input string that `d' points within. `d' is advanced into the following input string whenever necessary, but this happens before fetching; therefore, at the beginning of the loop, `d' can be pointing at the end of a string, but it cannot equal string2. */ if (pos <= size1) d = string1 + pos, dend = end_match_1; else d = string2 + pos - size1, dend = end_match_2;/* Write PREFETCH; just before fetching a character with *d. */#define PREFETCH \ while (d == dend) \ { if (dend == end_match_2) goto fail; /* end of string2 => failure */ \ d = string2; /* end of string1 => advance to string2. */ \ dend = end_match_2; } /* This loop loops over pattern commands. It exits by returning from the function if match is complete, or it drops through if match fails at this starting point in the input data. */ while (1) { if (p == pend) /* End of pattern means we have succeeded! */ { /* If caller wants register contents data back, convert it to indices */ if (regs) { regs->start[0] = pos; if (dend == end_match_1) regs->end[0] = d - string1; else regs->end[0] = d - string2 + size1; for (mcnt = 1; mcnt < RE_NREGS; mcnt++) { if (regend[mcnt] == (unsigned char *) -1) { regs->start[mcnt] = -1; regs->end[mcnt] = -1; continue; } if (regstart_seg1[mcnt]) regs->start[mcnt] = regstart[mcnt] - string1; else regs->start[mcnt] = regstart[mcnt] - string2 + size1; if (regend_seg1[mcnt]) regs->end[mcnt] = regend[mcnt] - string1; else regs->end[mcnt] = regend[mcnt] - string2 + size1; } } if (dend == end_match_1) return (d - string1 - pos); else return d - string2 + size1 - pos; } /* Otherwise match next pattern command */#ifdef SWITCH_ENUM_BUG switch ((int) ((enum regexpcode) *p++))#else switch ((enum regexpcode) *p++)#endif { /* \( is represented by a start_memory, \) by a stop_memory. Both of those commands contain a "register number" argument. The text matched within the \( and \) is recorded under that number. Then, \<digit> turns into a `duplicate' command which is followed by the numeric value of <digit> as the register number. */ case start_memory: regstart[*p] = d; regstart_seg1[*p++] = (dend == end_match_1); break; case stop_memory: regend[*p] = d; regend_seg1[*p++] = (dend == end_match_1); break; case duplicate: { int regno = *p++; /* Get which register to match against */ register unsigned char *d2, *dend2; d2 = regstart[regno]; dend2 = ((regstart_seg1[regno] == regend_seg1[regno]) ? regend[regno] : end_match_1); while (1) { /* Advance to next segment in register contents, if necessary */ while (d2 == dend2) { if (dend2 == end_match_2) break; if (dend2 == regend[regno]) break; d2 = string2, dend2 = regend[regno]; /* end of string1 => advance to string2. */ } /* At end of register contents => success */ if (d2 == dend2) break; /* Advance to next segment in data being matched, if necessary */ PREFETCH; /* mcnt gets # consecutive chars to compare */ mcnt = dend - d; if (mcnt > dend2 - d2) mcnt = dend2 - d2; /* Compare that many; failure if mismatch, else skip them. */ if (translate ? bcmp_translate (d, d2, mcnt, translate) : bcmp (d, d2, mcnt)) goto fail; d += mcn
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:gnu grep 1.5 ƒ:regex.c
+++++ Continued from previous card +++++
t, d2 += mcnt; } } break; case anychar: /* fetch a data character */ PREFETCH; /* Match anything but a newline. */ if ((translate ? translate[*d++] : *d++) == '\n') goto fail; break; case charset: case charset_not: { /* Nonzero for charset_not */ int not = 0; register int c; if (*(p - 1) == (unsigned char) charset_not) not = 1; /* fetch a data character */ PREFETCH; if (translate) c = translate [*d]; else c = *d; if (c < *p * BYTEWIDTH && p[1 + c / BYTEWIDTH] & (1 << (c % BYTEWIDTH))) not = !not; p += 1 + *p; if (!not) goto fail; d++; break; } case begline: if (d == string1 || d[-1] == '\n') break; goto fail; case endline: if (d == end2 || (d == end1 ? (size2 == 0 || *string2 == '\n') : *d == '\n')) break; goto fail; /* "or" constructs ("|") are handled by starting each alternative with an on_failure_jump that points to the start of the next alternative. Each alternative except the last ends with a jump to the joining point. (Actually, each jump except for the last one really jumps to the following jump, because tensioning the jumps is a hassle.) */ /* The start of a stupid repeat has an on_failure_jump that points past the end of the repeat text. This makes a failure point so that, on failure to match a repetition, matching restarts past as many repetitions have been found with no way to fail and look for another one. */ /* A smart repeat is similar but loops back to the on_failure_jump so that each repetition makes another failure point. */ case on_failure_jump: if (stackp == stacke) { unsigned char **stackx; if (stacke - stackb > re_max_failures * 2) return -2; stackx = (unsigned char **) alloca (2 * (stacke - stackb) * sizeof (char *)); bcopy (stackb, stackx, (stacke - stackb) * sizeof (char *)); stackp = stackx + (stackp - stackb); stacke = stackx + 2 * (stacke - stackb); stackb = stackx; } mcnt = *p++ & 0377; mcnt += SIGN_EXTEND_CHAR (*(char *)p) << 8; p++; *stackp++ = mcnt + p; *stackp++ = d; break; /* The end of a smart repeat has an maybe_finalize_jump back. Change it either to a finalize_jump or an ordinary jump. */ case maybe_finalize_jump: mcnt = *p++ & 0377; mcnt += SIGN_EXTEND_CHAR (*(char *)p) << 8; p++; { register unsigned char *p2 = p; /* Compare what follows with the begining of the repeat. If we can establish that there is nothing that they would both match, we can change to finalize_jump */ while (p2 != pend && (*p2 == (unsigned char) stop_memory || *p2 == (unsigned char) start_memory)) p2++; if (p2 == pend) p[-3] = (unsigned char) finalize_jump; else if (*p2 == (unsigned char) exactn || *p2 == (unsigned char) endline) { register int c = *p2 == (unsigned char) endline ? '\n' : p2[2]; register unsigned char *p1 = p + mcnt; /* p1[0] ... p1[2] are an on_failure_jump. Examine what follows that */ if (p1[3] == (unsigned char) exactn && p1[5] != c) p[-3] = (unsigned char) finalize_jump; else if (p1[3] == (unsigned char) charset || p1[3] == (unsigned char) charset_not) { int not = p1[3] == (unsigned char) charset_not; if (c < p1[4] * BYTEWIDTH && p1[5 + c / BYTEWIDTH] & (1 << (c % BYTEWIDTH))) not = !not; /* not is 1 if c would match */ /* That means it is not safe to finalize */ if (!not) p[-3] = (unsigned char) finalize_jump; } } } p -= 2; if (p[-1] != (unsigned char) finalize_jump) { p[-1] = (unsigned char) jump; goto nofinalize; } /* The end of a stupid repeat has a finalize-jump back to the start, where another failure point will be made which will point after all the repetitions foar. */ case finalize_jump: stackp -= 2; case jump: nofinalize: mcnt = *p++ & 0377; mcnt += SIGN_EXTEND_CHAR (*(char *)p) << 8; p += mcnt + 1; /* The 1 compensates for missing ++ above */ break; case dummy_failure_jump: if (stackp == stacke) { unsigned char **stackx = (unsigned char **) alloca (2 * (stacke - stackb) * sizeof (char *)); bcopy (stackb, stackx, (stacke - stackb) * sizeof (char *)); stackp = stackx + (stackp - stackb); stacke = stackx + 2 * (stacke - stackb); stackb = stackx; } *stackp++ = 0; *stackp++ = 0; goto nofinalize; case wordbound: if (d == string1 /* Points to first char */ || d == end2 /* Points to end */ || (d == end1 && size2 == 0)) /* Points to end */ break; if ((SYNTAX (d[-1]) == Sword) != (SYNTAX (d == end1 ? *string2 : *d) == Sword)) break; goto fail; case notwordbound: if (d == string1 /* Points to first char */ || d == end2 /* Points to end */ || (d == end1 && size2 == 0)) /* Points to end */ goto fail; if ((SYNTAX (d[-1]) == Sword) != (SYNTAX (d == end1 ? *string2 : *d) == Sword)) goto fail; break; case wordbeg: if (d == end2 /* Points to end */ || (d == end1 && size2 == 0) /* Points to end */ || SYNTAX (* (d == end1 ? string2 : d)) != Sword) /* Next char not a letter */ goto fail; if (d == string1 /* Points to first char */ || SYNTAX (d[-1]) != Sword) /* prev char not letter */ break; goto fail; case wordend: if (d == string1 /* Points to first char */ || SYNTAX (d[-1]) != Sword) /* prev char not letter */ goto fail; if (d == end2 /* Points to end */ || (d == end1 && size2 == 0) /* Points to end */ || SYNTAX (d == end1 ? *string2 : *d) != Sword) /* Next char not a letter */ break; goto fail;#ifdef emacs case before_dot: if (((d - string2 <= (unsigned) size2) ? d - bf_p2 : d - bf_p1) <= point) goto fail; break; case at_dot: if (((d - string2 <= (unsigned) size2) ? d - bf_p2 : d - bf_p1) == point) goto fail; break; case after_dot: if (((d - string2 <= (unsigned) size2) ? d - bf_p2 : d - bf_p1) >= point) goto fail; break; case wordchar: mcnt = (int) Sword; goto matchsyntax; case syntaxspec: mcnt = *p++; matchsyntax: PREFETCH; if (SYNTAX (*d++) != (enum syntaxcode) mcnt) goto fail; break; case notwordchar: mcnt = (int) Sword; goto matchnotsyntax; case notsyntaxspec: mcnt = *p++; matchnotsyntax: PREFETCH; if (SYNTAX (*d++) == (enum syntaxcode) mcnt) goto fail; break;#else case wordchar: PREFETCH; if (SYNTAX (*d++) == 0) goto fail; break; case notwordchar: PREFETCH; if (SYNTAX (*d++) != 0) goto fail; break;#endif /* not emacs */ case begbuf: if (d == string1) /* Note, d cannot equal string2 */ break; /* unless string1 == string2. */ goto fail; case endbuf: if (d == end2 || (d == end1 && size2 == 0)) break; goto fail; case exactn: /* Match the next few pattern characters exactly. mcnt is how many characters to match. */ mcnt = *p++; if (translate) { do { PREFETCH; if (translate[*d++] != *p++) goto fail; } while (--mcnt); } else { do { PREFETCH; if (*d++ != *p++) goto fail; } while (--mcnt); } break; } continue; /* Successfully matched one pattern command; keep matching */ /* Jump here if any matching operation fails. */ fail: if (stackp != stackb) /* A restart point is known. Restart there and pop it. */ { if (!stackp[-2]) { /* If innermost failure point is dormant, flush it and keep looking */ stackp -= 2; goto fail; } d = *--stackp; p = *--stackp; if (d >= string1 && d <= end1) dend = end_match_1; } else break; /* Matching at this starting point really fails! */ } return -1; /* Failure to match */}static intbcmp_translate (s1, s2, len, translate) unsigned char *s1, *s2; register int len; unsigned char *translate;{ register unsigned char *p1 = s1, *p2 = s2; while (len) { if (translate [*p1++] != translate [*p2++]) return 1; len--; } return 0;} /* Entry points compatible with bsd4.2 regex library */#ifndef emacsstatic struct re_pattern_buffer re_comp_buf;char *re_comp (s) char *s;{ if (!s) { if (!re_comp_buf.buffer) return "No previous regular expression"; return 0; } if (!re_comp_buf.buffer) { if (!(re_comp_buf.buffer = (char *) malloc (200))) return "Memory exhausted"; re_comp_buf.allocated = 200; if (!(re_comp_buf.fastmap = (char *) malloc (1 << BYTEWIDTH))) return "Memory exhausted"; } return re_compile_pattern (s, strlen (s), &re_comp_buf);}intre_exec (s) char *s;{ int len = strlen (s); return 0 <= re_search (&re_comp_buf, s, len, 0, len, 0);}#endif /* emacs */ #ifdef test#include <stdio.h>/* Indexed by a character, gives the upper case equivalent of the character */static char upcase[0400] = { 000, 001, 002, 003, 004, 005, 006, 007, 010, 011, 012, 013, 014, 015, 016, 017, 020, 021, 022, 023, 024, 025, 026, 027, 030, 031, 032, 033, 034, 035, 036, 037, 040, 041, 042, 043, 044, 045, 046, 047, 050, 051, 052, 053, 054, 055, 056, 057, 060, 061, 062, 063, 064, 065, 066, 067, 070, 071, 072, 073, 074, 075, 076, 077, 0100, 0101, 0102, 0103, 0104, 0105, 0106, 0107, 0110, 0111, 0112, 0113, 0114, 0115, 0116, 0117, 0120, 0121, 0122, 0123, 0124, 0125, 0126, 0127, 0130, 0131, 0132, 0133, 0134, 0135, 0136, 0137, 0140, 0101, 0102, 0103, 0104, 0105, 0106, 0107, 0110, 0111, 0112, 0113, 0114, 0115, 0116, 0117, 0120, 0121, 0122, 0123, 0124, 0125, 0126, 0127, 0130, 0131, 0132, 0173, 0174, 0175, 0176, 0177, 0200, 0201, 0202, 0203, 0204, 0205, 0206, 0207, 0210, 0211, 0212, 0213, 0214, 0215, 0216, 0217, 0220, 0221, 0222, 0223, 0224, 0225, 0226, 0227, 0230, 0231, 0232, 0233, 0234, 0235, 0236, 0237, 0240, 0241, 0242, 0243, 0244, 0245, 0246, 0247, 0250, 0251, 0252, 0253, 0254, 0255, 0256, 0257, 0260, 0261, 0262, 0263, 0264, 0265, 0266, 0267, 0270, 0271, 0272, 0273, 0274, 0275, 0276, 0277, 0300, 0301, 0302, 0303, 0304, 0305, 0306, 0307, 0310, 0311, 0312, 0313, 0314, 0315, 0316, 0317, 0320, 0321, 0322, 0323, 0324, 0325, 0326, 0327, 0330, 0331, 0332, 0333, 0334, 0335, 0336, 0337, 0340, 0341, 0342, 0343, 0344, 0345, 0346, 0347, 0350, 0351, 0352, 0353, 0354, 0355, 0356, 0357, 0360, 0361, 0362, 0363, 0364, 0365, 0366, 0367, 0370, 0371, 0372, 0373, 0374, 0375, 0376, 0377 };main (argc, argv) int argc; char **argv;{ char pat[80]; struct re_pattern_buffer buf; int i; char c; char fastmap[(1 << BYTEWIDTH)]; /* Allow a command argument to specify the style of syntax. */ if (argc > 1) obscure_syntax = atoi (argv[1]); buf.allocated = 40; buf.buffer = (char *) malloc (buf.allocated); buf.fastmap = fastmap; buf.translate = upcase; while (1) { gets (pat); if (*pat) { re_compile_pattern (pat, strlen(pat), &buf); for (i = 0; i < buf.used; i++) printchar (buf.buffer[i]); putchar ('\n'); printf ("%d allocated, %d used.\n", buf.allocated, buf.used); re_compile_fastmap (&buf); printf ("Allowed by fastmap: "); for (i = 0; i < (1 << BYTEWIDTH); i++) if (fastmap[i]) printchar (i); putchar ('\n'); } gets (pat); /* Now read the string to match against */ i = re_match (&buf, pat, strlen (pat), 0, 0); printf ("Match value %d.\n", i); }}#ifdef NOTDEFprint_buf (bufp) struct re_pattern_buffer *bufp;{ int i; printf ("buf is :\n----------------\n"); for (i = 0; i < bufp->used; i++) printchar (bufp->buffer[i]); printf ("\n%d allocated, %d used.\n", bufp->allocated, bufp->used); printf ("Allowed by fastmap: "); for (i = 0; i < (1 << BYTEWIDTH); i++) if (bufp->fastmap[i]) printchar (i); printf ("\nAllowed by translate: "); if (bufp->translate) for (i = 0; i < (1 << BYTEWIDTH); i++) if (bufp->translate[i]) printchar (i); printf ("\nfastmap is%s accurate\n", bufp->fastmap_accurate ? "" : "n't"); printf ("can %s be null\n----------", bufp->can_be_null ? "" : "not");}#endifprintchar (c) char c;{ if (c < 041 || c >= 0177) { putchar ('\\'); putchar (((c >> 6) & 3) + '0'); putchar (((c >> 3) & 7) + '0'); putchar ((c & 7) + '0'); } else putchar (c);}error (string) char *string;{ puts (string); exit (1);}#endif /* test */ :MPW:MPW Tools:Tools with Source:gnu grep 1.5 ƒ:regex.h
/* Definitions for data structures callers pass the regex library. Copyright (C) 1985, 1989 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. In other words, you are welcome to use, share and improve this program. You are forbidden to forbid anyone else to use, share and improve what you give them. Help stamp out software-hoarding! *//* Define number of parens for which we record the beginnings and ends. This affects how much space the `struct re_registers' type takes up. */#ifndef RE_NREGS#define RE_NREGS 10#endif/* These bits are used in the obscure_syntax variable to choose among alternative regexp syntaxes. *//* 1 means plain parentheses serve as grouping, and backslash parentheses are needed for literal searching. 0 means backslash-parentheses are grouping, and plain parentheses are for literal searching. */#define RE_NO_BK_PARENS 1/* 1 means plain | serves as the "or"-operator, and \| is a literal. 0 means \| serves as the "or"-operator, and | is a literal. */#define RE_NO_BK_VBAR 2/* 0 means plain + or ? serves as an operator, and \+, \? are literals. 1 means \+, \? are operators and plain +, ? are literals. */#define RE_BK_PLUS_QM 4/* 1 means | binds tighter than ^ or $. 0 means the contrary. */#define RE_TIGHT_VBAR 8/* 1 means treat \n as an _OR operator 0 means treat it as a normal character */#define RE_NEWLINE_OR 16/* 0 means that a special characters (such as *, ^, and $) always have their special meaning regardless of the surrounding context. 1 means that special characters may act as normal characters in some contexts. Specifically, this applies to: ^ - only special at the beginning, or after ( or | $ - only special at the end, or before ) or | *, +, ? - only special when not after the beginning, (, or | */#define RE_CONTEXT_INDEP_OPS 32/* Now define combinations of bits for the standard possibilities. */#define RE_SYNTAX_AWK (RE_NO_BK_PARENS | RE_NO_BK_VBAR | RE_CONTEXT_INDEP_OPS)#define RE_SYNTAX_EGREP (RE_SYNTAX_AWK | RE_NEWLINE_OR)#define RE_SYNTAX_GREP (RE_BK_PLUS_QM | RE_NEWLINE_OR)#define RE_SYNTAX_EMACS 0/* This data structure is used to represent a compiled pattern. */struct re_pattern_buffer { char *buffer; /* Space holding the compiled pattern commands. */ int allocated; /* Size of space that buffer points to */ int used; /* Length of portion of buffer actually occupied */ char *fastmap; /* Pointer to fastmap, if any, or zero if none. */ /* re_search uses the fastmap, if there is one, to skip quickly over totally implausible characters */ char *translate; /* Translate table to apply to all characters before comparing. Or zero for no translation. The translation is applied to a pattern when it is compiled and to data when it is matched. */ char fastmap_accurate; /* Set to zero when a new pattern is stored, set to one when the fastmap is updated from it. */ char can_be_null; /* Set to one by compiling fastmap if this pattern might match the null string. It does not necessarily match the null string in that case, but if this is zero, it cannot. 2 as value means can match null string but at end of range or before a character listed in the fastmap. */ };/* Structure to store "register" contents data in. Pass the address of such a structure as an argument to re_match, etc., if you want this information back. start[i] and end[i] record the string matched by \( ... \) grouping i, for i from 1 to RE_NREGS - 1. start[0] and end[0] record the entire string matched. */struct re_registers { int start[RE_NREGS]; int end[RE_NREGS]; };/* These are the command codes that appear in compiled regular expressions, one per byte. Some command codes are followed by argument bytes. A command code can specify any interpretation whatever for its arguments. Zero-bytes may appear in the compiled regular expression. */enum regexpcode { unused, exactn, /* followed by one byte giving n, and then by n literal bytes */ begline, /* fails unless at beginning of line */ endline, /* fails unless at end of line */ jump, /* followed by two bytes giving relative address to jump to */ on_failure_jump, /* followed by two bytes giving relative address of place to resume at in case of failure. */ finalize_jump, /* Throw away latest failure point and then jump to address. */ maybe_finalize_jump, /* Like jump but finalize if safe to do so. This is used to jump back to the beginning of a repeat. If the command that follows this jump is clearly incompatible with the one at the beginning of the repeat, such that we can be sure that there is no use backtracking out of repetitions already completed, then we finalize. */ dummy_failure_jump, /* jump, and push a dummy failure point. This failure point will be thrown away if an attempt is made to use it for a failure. A + construct makes this before the first repeat. */ anychar, /* matches any one character */ charset, /* matches any one char belonging to specified set. First following byte is # bitmap bytes. Then come bytes for a bit-map saying which chars are in. Bits in each byte are ordered low-bit-first. A character is in the set if its bit is 1. A character too large to have a bit in the map is automatically not in the set */ charset_not, /* similar but match any character that is NOT one of those specified */ start_memory, /* starts remembering the text that is matched and stores it in a memory register. followed by one byte containing the register number. Register numbers must be in the range 0 through NREGS. */ stop_memory, /* stops remembering the text that is matched and stores it in a memory register. followed by one byte containing the register number. Register numbers must be in the range 0 through NREGS. */ duplicate, /* match a duplicate of something remembered. Followed by one byte containing the index of the memory register. */ before_dot, /* Succeeds if before dot */ at_dot, /* Succeeds if at dot */ after_dot, /* Succeeds if after dot */ begbuf, /* Succeeds if at beginning of buffer */ endbuf, /* Succeeds if at end of buffer */ wordchar, /* Matches any word-constituent character */ notwordchar, /* Matches any char that is not a word-constituent */ wordbeg, /* Succeeds if at word beginning */ wordend, /* Succeeds if at word end */ wordbound, /* Succeeds if at a word boundary */ notwordbound, /* Succeeds if not at a word boundary */ syntaxspec, /* Matches any character whose syntax is specified. followed by a byte which contains a syntax code, Sword or such like */ notsyntaxspec /* Matches any character whose syntax differs from the specified. */ }; extern char *re_compile_pattern ();/* Is this really advertised? */extern void re_compile_fastmap ();extern int re_search (), re_search_2 ();extern int re_match (), re_match_2 ();/* 4.2 bsd compatibility (yuck) */extern char *re_comp ();extern int re_exec ();#ifdef SYNTAX_TABLEextern char *re_syntax_table;#endif :MPW:MPW Tools:Tools with Source:gnu grep 1.5 ƒ:tests:anderson.script
Set failures 0export failures# The Khadafy test is brought to you by Scott Anderson . . .set exit 0::egrep -f khadafy.regexp khadafy.lines > khadafy.outcompare khadafy.lines khadafy.out ∑∑ Dev:Nullif {Status} == 0 echo "test completed OK" delete khadafy.outelse echo "Khadafy test failed -- output left on khadafy.out" Set failures 1endset exit 1 :MPW:MPW Tools:Tools with Source:gnu grep 1.5 ƒ:tests:khadafy.lines
0:abc:abc1:abc:xbc1:abc:axc1:abc:abx0:abc:xabcy0:abc:ababc0:ab*c:abc0:ab*bc:abc0:ab*bc:abbc0:ab*bc:abbbbc0:ab+bc:abbc1:ab+bc:abc1:ab+bc:abq0:ab+bc:abbbbc0:ab?bc:abbc0:ab?bc:abc1:ab?bc:abbbbc0:ab?c:abc0:^abc$:abc1:^abc$:abcc0:^abc:abcc1:^abc$:aabc0:abc$:aabc0:^:abc0:$:abc0:a.c:abc0:a.c:axc0:a.*c:axyzc1:a.*c:axyzd1:a[bc]d:abc0:a[bc]d:abd1:a[b-d]e:abd0:a[b-d]e:ace0:a[b-d]:aac0:a[-b]:a-2:a[b-]:a-1:a[b-a]:-2:a[]b:-2:a[:-0:a]:a]0:a[]]b:a]b0:a[^bc]d:aed1:a[^bc]d:abd0:a[^-b]c:adc1:a[^-b]c:a-c1:a[^]b]c:a]c0:a[^]b]c:adc0:ab|cd:abc0:ab|cd:abcd0:()ef:def0:()*:-1:*a:-0:^*:-0:$*:-1:(*)b:-1:$b:b2:a\:-0:a\(b:a(b0:a\(*b:ab0:a\(*b:a((b1:a\x:a\x2:abc):-2:(abc:-0:((a)):abc0:(a)b(c):abc0:a+b+c:aabbabc0:a**:-0:a*?:-0:(a*)*:-0:(a*)+:-0:(a|)*:-0:(a*|b)*:-0:(a+|b)*:ab0:(a+|b)+:ab0:(a+|b)?:ab0:[^ab]*:cde0:(^)*:-0:(ab|)*:-2:)(:-1:abc:1:abc:0:a*:0:([abc])*d:abbbcd0:([abc])*bcd:abcd0:a|b|c|d|e:e0:(a|b|c|d|e)f:ef0:((a*|b))*:-0:abcd*efg:abcdefg0:ab*:xabyabbbz0:ab*:xayabbbz0:(ab|cd)e:abcde0:[abhgefdc]ij:hij1:^(ab|cd)e:abcde0:(abc|)ef:abcdef0:(a|b)c*d:abcd0:(ab|ab*)bc:abc0:a([bc]*)c*:abc0:a([bc]*)(c*d):abcd0:a([bc]+)(c*d):abcd0:a([bc]*)(c+d):abcd0:a[bcd]*dcdcde:adcdcde1:a[bcd]+dcdcde:adcdcde0:(ab|a)b*c:abc0:((a)(b)c)(d):abcd0:[A-Za-z_][A-Za-z0-9_]*:alpha0:^a(bc+|b[eh])g|.h$:abh0:(bc+d$|ef*g.|h?i(j|k)):effgz0:(bc+d$|ef*g.|h?i(j|k)):ij1:(bc+d$|ef*g.|h?i(j|k)):effg1:(bc+d$|ef*g.|h?i(j|k)):bcdd0:(bc+d$|ef*g.|h?i(j|k)):reffgz1:((((((((((a)))))))))):-0:(((((((((a))))))))):a1:multiple words of text:uh-uh0:multiple words:multiple words, yeah0:(.*)c(.*):abcde1:\((.*),:(.*)\)1:[k]:ab0:abcd:abcd0:a(bc)d:abcd0:a[-]?c:ac0:(....).*\1:beriberi :MPW:MPW Tools:Tools with Source:gnu grep 1.5 ƒ:tests:spenecer.script
# the following by Henry Spencer. (requires gawk)Set failures 0gawk -F: -f scriptgen.awk spencer.tests > tmp.scriptexecute tmp.scriptif {status} == 0 delete tmp.script exit {failures}else delete tmp.script exit 1end :MPW:MPW Tools:Tools with Source:gnu grep 1.5 ƒ:unixMakefile
## Makefile for GNU e?grep## Add -DUSG for System V.CFLAGS = -O## You may add getopt.o if your C library lacks getopt(); note that# 4.3BSD getopt() is said to be somewhat broken.## Add alloca.o if your machine does not support alloca().#OBJS = dfa.o regex.oGOBJ = grep.oEOBJ = egrep.o# Space provided for machine dependent libraries.LIBS =all: regressregress: egrep grep cd tests; sh regress.shegrep: $(OBJS) $(EOBJ) $(CC) $(CFLAGS) -o egrep $(OBJS) $(EOBJ) $(LIBS)egrep.o: grep.c rm -f egrep.c; cp grep.c egrep.c $(CC) $(CFLAGS) -DEGREP -c egrep.c rm -f egrep.cgrep: $(OBJS) $(GOBJ) $(CC) $(CFLAGS) -o grep $(OBJS) $(GOBJ) $(LIBS)clean: rm -f grep egrep *.o core tests/core tests/tmp.script \ tests/khadafy.out egrep.cdfa.o egrep.o grep.o: dfa.hegrep.o grep.o regex.o: regex.h :MPW:MPW Tools:Tools with Source:gnu sed ƒ:alloca.c
/* alloca -- (mostly) portable public-domain implementation -- D A Gwyn last edit: 86/05/30 rms include config.h, since on VMS it renames some symbols. Use xmalloc instead of malloc. This implementation of the PWB library alloca() function, which is used to allocate space off the run-time stack so that it is automatically reclaimed upon procedure exit, was inspired by discussions with J. Q. Johnson of Cornell. It should work under any C implementation that uses an actual procedure stack (as opposed to a linked list of frames). There are some preprocessor constants that can be defined when compiling for your specific system, for improved efficiency; however, the defaults should be okay. The general concept of this implementation is to keep track of all alloca()-allocated blocks, and reclaim any that are found to be deeper in the stack than the current invocation. This heuristic does not reclaim storage as soon as it becomes invalid, but it will do so eventually. As a special case, alloca(0) reclaims storage without allocating any. It is a good idea to use alloca(0) in your main control loop, etc. to force garbage collection.*/#ifdef macintosh#define xmalloc malloc#endif#ifndef lintstatic char SCCSid[] = "@(#)alloca.c 1.1"; /* for the "what" utility */#endif#ifdef emacs#include "config.h"#ifdef static/* actually, only want this if static is defined as "" -- this is for usg, in which emacs must undefine static in order to make unexec workable */#ifndef STACK_DIRECTIONyoulose-- must know STACK_DIRECTION at compile-time#endif /* STACK_DIRECTION undefined */#endif static#endif emacs#ifdef X3J11typedef void *pointer; /* generic pointer type */#elsetypedef char *pointer; /* generic pointer type */#endif#define NULL 0 /* null pointer constant */extern void free();extern pointer xmalloc();/* Define STACK_DIRECTION if you know the direction of stack growth for your system; otherwise it will be automatically deduced at run-time. STACK_DIRECTION > 0 => grows toward higher addresses STACK_DIRECTION < 0 => grows toward lower addresses STACK_DIRECTION = 0 => direction of growth unknown*/#ifndef STACK_DIRECTION#define STACK_DIRECTION 0 /* direction unknown */#endif#if STACK_DIRECTION != 0#define STACK_DIR STACK_DIRECTION /* known at compile-time */#else /* STACK_DIRECTION == 0; need run-time code */static int stack_dir; /* 1 or -1 once known */#define STACK_DIR stack_dirstatic voidfind_stack_direction (/* void */){ static char *addr = NULL; /* address of first `dummy', once known */ auto char dummy; /* to get stack address */ if (addr == NULL) { /* initial entry */ addr = &dummy; find_stack_direction (); /* recurse once */ } else /* second entry */ if (&dummy > addr) stack_dir = 1; /* stack grew upward */ else stack_dir = -1; /* stack grew downward */}#endif /* STACK_DIRECTION == 0 *//* An "alloca header" is used to: (a) chain together all alloca()ed blocks; (b) keep track of stack depth. It is very important that sizeof(header) agree with malloc() alignment chunk size. The following default should work okay.*/#ifndef ALIGN_SIZE#define ALIGN_SIZE sizeof(double)#endiftypedef union hdr{ char align[ALIGN_SIZE]; /* to force sizeof(header) */ struct { union hdr *next; /* for chaining headers */ char *deep; /* for stack depth measure */ } h;} header;/* alloca( size ) returns a pointer to at least `size' bytes of storage which will be automatically reclaimed upon exit from the procedure that called alloca(). Originally, this space was supposed to be taken from the current stack frame of the caller, but that method cannot be made to work for some implementations of C, for example under Gould's UTX/32.*/static header *last_alloca_header = NULL; /* -> last alloca header */pointeralloca (size) /* returns pointer to storage */ unsigned size; /* # bytes to allocate */{ auto char probe; /* probes stack depth: */ register char *depth = &probe;#if STACK_DIRECTION == 0 if (STACK_DIR == 0) /* unknown growth direction */ find_stack_direction ();#endif /* Reclaim garbage, defined as all alloca()ed storage that was allocated from deeper in the stack than currently. */ { register header *hp; /* traverses linked list */ for (hp = last_alloca_header; hp != NULL;) if (STACK_DIR > 0 && hp->h.deep > depth || STACK_DIR < 0 && hp->h.deep < depth) { register header *np = hp->h.next; free ((pointer) hp); /* collect garbage */ hp = np; /* -> next header */ } else break; /* rest are not deeper */ last_alloca_header = hp; /* -> last valid storage */ } if (size == 0) return NULL; /* no allocation required */ /* Allocate combined header + user data storage. */ { register pointer new = xmalloc (sizeof (header) + size); /* address of header */ ((header *)new)->h.next = last_alloca_header; ((header *)new)->h.deep = depth; last_alloca_header = (header *)new; /* User storage begins just after header. */ return (pointer)((char *)new + sizeof(header)); }} :MPW:MPW Tools:Tools with Source:gnu sed ƒ:att.getopt.c
/*** @(#)getopt.c 2.5 (smail) 9/15/87*//* * Here's something you've all been waiting for: the AT&T public domain * source for getopt(3). It is the code which was given out at the 1985 * UNIFORUM conference in Dallas. I obtained it by electronic mail * directly from AT&T. The people there assure me that it is indeed * in the public domain. * * There is no manual page. That is because the one they gave out at * UNIFORUM was slightly different from the current System V Release 2 * manual page. The difference apparently involved a note about the * famous rules 5 and 6, recommending using white space between an option * and its first argument, and not grouping options that have arguments. * Getopt itself is currently lenient about both of these things White * space is allowed, but not mandatory, and the last option in a group can * have an argument. That particular version of the man page evidently * has no official existence, and my source at AT&T did not send a copy. * The current SVR2 man page reflects the actual behavor of this getopt. * However, I am not about to post a copy of anything licensed by AT&T. *//* This include is needed only to get "index" defined as "strchr" on Sys V. */#ifdef MSDOS#define index strchr#else#ifdef macintosh#define index strchr#else#include "#endif#endif/*LINTLIBRARY*/#define NULL 0#define EOF (-1)#define ERR(s, c) if(opterr){\ extern int write();\ char errbuf[2];\ errbuf[0] = c; errbuf[1] = '\n';\ (void) write(2, argv[0], (unsigned)strlen(argv[0]));\ (void) write(2, s, (unsigned)strlen(s));\ (void) write(2, errbuf, 2);}extern char *index();int opterr = 1;int optind = 1;int optopt;char *optarg;intgetopt(argc, argv, opts)int argc;char **argv, *opts;{ static int sp = 1; register int c; register char *cp; if(sp == 1) if(optind >= argc || argv[optind][0] != '-' || argv[optind][1] == '\0') return(EOF); else if(strcmp(argv[optind], "--") == NULL) { optind++; return(EOF); } optopt = c = argv[optind][sp]; if(c == ':' || (cp=index(opts, c)) == NULL) { ERR(": illegal option -- ", c); if(argv[optind][++sp] == '\0') { optind++; sp = 1; } return('?'); } if(*++cp == ':') { if(argv[optind][sp+1] != '\0') optarg = &argv[optind++][sp+1]; else if(++optind >= argc) { ERR(": option requires an argument -- ", c); sp = 1; return('?'); } else optarg = argv[optind++]; sp = 1; } else { if(argv[optind][++sp] == '\0') { sp = 1; optind++; } optarg = NULL; } return(c);} :MPW:MPW Tools:Tools with Source:gnu sed ƒ:COPYING
GNU GENERAL PUBLIC LICENSE Version 1, February 1989 Copyright (C) 1989 Free Software Foundation, Inc. 675 Mass Ave, Cambridge, MA 02139, USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The license agreements of most software companies try to keep usersat the mercy of those companies. By contrast, our General PublicLicense is intended to guarantee your freedom to share and change freesoftware--to make sure the software is free for all its users. TheGeneral Public License applies to the Free Software Foundation'ssoftware and to any other program whose authors commit to using it.You can use it for your programs, too. When we speak of free software, we are referring to freedom, notprice. Specifically, the General Public License is designed to makesure that you have the freedom to give away or sell copies of freesoftware, that you receive source code or can get it if you want it,that you can change the software or use pieces of it in new freeprograms; and that you know you can do these things. To protect your rights, we need to make restrictions that forbidanyone to deny you these rights or to ask you to surrender the rights.These restrictions translate to certain responsibilities for you if youdistribute copies of the software, or if you modify it. For example, if you distribute copies of a such a program, whethergratis or for a fee, you must give the recipients all the rights thatyou have. You must make sure that they, too, receive or can get thesource code. And you must tell them their rights. We protect your rights with two steps: (1) copyright the software, and(2) offer you this license which gives you legal permission to copy,distribute and/or modify the software. Also, for each author's protection and ours, we want to make certainthat everyone understands that there is no warranty for this freesoftware. If the software is modified by someone else and passed on, wewant its recipients to know that what they have is not the original, sothat any problems introduced by others will not reflect on the originalauthors' reputations. The precise terms and conditions for copying, distribution andmodification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any program or other work whichcontains a notice placed by the copyright holder saying it may bedistributed under the terms of this General Public License. The"Program", below, refers to any such program or work, and a "work basedon the Program" means either the Program or any work containing theProgram or a portion of it, either verbatim or with modifications. Eachlicensee is addressed as "you". 1. You may copy and distribute verbatim copies of the Program's sourcecode as you receive it, in any medium, provided that you conspicuously andappropriately publish on each copy an appropriate copyright notice anddisclaimer of warranty; keep intact all the notices that refer to thisGeneral Public License and to the absence of any warranty; and give anyother recipients of the Program a copy of this General Public Licensealong with the Program. You may charge a fee for the physical act oftransferring a copy. 2. You may modify your copy or copies of the Program or any portion ofit, and copy and distribute such modifications under the terms of Paragraph1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains the Program or any part thereof, either with or without modifications, to be licensed at no charge to all third parties under the terms of this General Public License (except that you may choose to grant warranty protection to some or all third parties, at your option). c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the simplest and most usual way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this General Public License. d) You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee.Mere aggregation of another independent work with the Program (or itsderivative) on a volume of a storage or distribution medium does not bringthe other work under the scope of these terms. 3. You may copy and distribute the Program (or a portion or derivative ofit, under Paragraph 2) in object code or executable form under the terms ofParagraphs 1 and 2 above provided that you also do one of the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal charge for the cost of distribution) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.)Source code for a work means the preferred form of the work for makingmodifications to it. For an executable file, complete source code meansall the source code for all modules it contains; but, as a specialexception, it need not include source code for modules which are standardlibraries that accompany the operating system on which the executablefile runs, or for standard header files or definitions files thataccompany that operating system. 4. You may not copy, modify, sublicense, distribute or transfer theProgram except as expressly provided under this General Public License.Any attempt otherwise to copy, modify, sublicense, distribute or transferthe Program is void, and will automatically terminate your rights to usethe Program under this License. However, parties who have receivedcopies, or rights to use copies, from you under this General PublicLicense will not have their licenses terminated so long as such partiesremain in full compliance. 5. By copying, distributing or modifying the Program (or any work basedon the Program) you indicate your acceptance of this license to do so,and all its terms and conditions. 6. Each time you redistribute the Program (or any work based on theProgram), the recipient automatically receives a license from the originallicensor to copy, distribute or modify the Program subject to theseterms and conditions. You may not impose any further restrictions on therecipients' exercise of the rights granted herein. 7. The Free Software Foundation may publish revised and/or new versionsof the General Public License from time to time. Such new versions willbe similar in spirit to the present version, but may differ in detail toaddress new problems or concerns.Each version is given a distinguishing version number. If the Programspecifies a version number of the license which applies to it and "anylater version", you have the option of following the terms and conditionseither of that version or of any later version published by the FreeSoftware Foundation. If the Program does not specify a version number ofthe license, you may choose any version ever published by the Free SoftwareFoundation. 8. If you wish to incorporate parts of the Program into other freeprograms whose distribution conditions are different, write to the authorto ask for permission. For software which is copyrighted by the FreeSoftware Foundation, write to the Free Software Foundation; we sometimesmake exceptions for this. Our decision will be guided by the two goalsof preserving the free status of all derivatives of our free software andof promoting the sharing and reuse of software generally. NO WARRANTY 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTYFOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHENOTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIESPROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSEDOR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OFMERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK ASTO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THEPROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,REPAIR OR CORRECTION. 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITINGWILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/ORREDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISINGOUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITEDTO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BYYOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHERPROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THEPOSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatestpossible use to humanity, the best way to achieve this is to make itfree software which everyone can redistribute and change under theseterms. To do so, attach the following notices to the program. It is safest toattach them to the start of each source file to most effectively conveythe exclusion of warranty; and each file should have at least the"copyright" line and a pointer to where the full notice is found. <one line to give the program's name and a brief idea of what it does.> Copyright (C) 19yy <name of author> This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.Also add information on how to contact you by electronic and paper mail.If the program is interactive, make it output a short notice like thiswhen it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19xx name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details.The hypothetical commands `show w' and `show c' should show theappropriate parts of the General Public License. Of course, thecommands you use may be called something other than `show w' and `showc'; they could even be mouse-clicks or menu items--whatever suits yourprogram.You should also get your employer (if you work as a programmer) or yourschool, if any, to sign a "copyright disclaimer" for the program, ifnecessary. Here a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (a program to direct compilers to make passes at assemblers) written by James Hacker. <signature of Ty Coon>, 1 April 1989 Ty Coon, President of ViceThat's all there is to it! :MPW:MPW Tools:Tools with Source:gnu sed ƒ:glob.c
/* File-name wildcard pattern matching for GNU. Copyright (C) 1985, 1988, 1989 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *//* To whomever it may concern: I have never seen the code which most Unix programs use to perform this function. I wrote this from scratch based on specifications for the pattern matching. */#ifdef macintosh#include <types.h>#else#include <sys/types.h>#endif#ifdef USGr3#include <dirent.h>#define direct dirent#define D_NAMLEN(d) strlen((d)->d_name)#else /* not USGr3 */#define D_NAMLEN(d) ((d)->d_namlen)# ifdef USG#ifndef macintosh#include "ndir.h" /* Get ndir.h from the Emacs distribution. */#endif macintosh# else /* not USG */#include <sys/dir.h># endif /* USG */#endif /* USGr3 */#ifdef USG#include <memory.h>#include <string.h>#define bcopy(s, d, n) ((void) memcpy ((d), (s), (n)))#define rindex strrchrstruct passwd *getpwent(), *getpwuid(), *getpwnam();extern char *memcpy ();#else /* not USG */#include <strings.h>extern void bcopy ();#endif /* not USG */#ifdef __GNUC__#define alloca(n) __builtin_alloca (n)#else /* Not GCC. */#ifdef sparc#include <alloca.h>#else /* Not sparc. */extern char *alloca ();#endif /* sparc. */#endif /* GCC. *///#include <pwd.h>extern char *malloc (), *realloc ();extern void free ();#ifndef NULL#define NULL 0#endif/* Zero if * matches .*. */int noglob_dot_filenames = 1;/* Nonzero if ~ and ~USER are expanded by glob_filename. */int glob_tilde = 0;static int glob_match_after_star ();/* Return nonzero if PATTERN has any special globbing chars in it. */intglob_pattern_p (pattern) char *pattern;{ register char *p = pattern; register char c; while ((c = *p++)) { switch (c) { case '?': case '[': case '*': return 1; case '\\': if (*p++ == 0) return 0; default: ; } } return 0;}/* Match the pattern PATTERN against the string TEXT; return 1 if it matches, 0 otherwise. A match means the entire string TEXT is used up in matching. In the pattern string, `*' matches any sequence of characters, `?' matches any character, [SET] matches any character in the specified set, [^SET] matches any character not in the specified set. A set is composed of characters or ranges; a range looks like character hyphen character (as in 0-9 or A-Z). [0-9a-zA-Z_] is the set of characters allowed in C identifiers. Any other character in the pattern must be matched exactly. To suppress the special syntactic significance of any of `[]*?^-\', and match the character exactly, precede it with a `\'. If DOT_SPECIAL is nonzero, `*' and `?' do not match `.' at the beginning of TEXT. */intglob_match (pattern, text, dot_special) char *pattern, *text; int dot_special;{ register char *p = pattern, *t = text; register char c; while ((c = *p++)) { switch (c) { case '?': if (*t == 0 || (dot_special && t == text && *t == '.')) return 0; else ++t; break; case '\\': if (*p++ != *t++) return 0; break; case '*': if (dot_special && t == text && *t == '.') return 0; return glob_match_after_star (p, t); case '[': { register char c1 = *t++; register int invert = (*p == '^'); if (invert) p++; c = *p++; while (1) { register char cstart = c, cend = c; if (c == '\\') { cstart = *p++; cend = cstart; } if (!c) return (0); c = *p++; if (c == '-') { cend = *p++; if (cend == '\\') cend = *p++; if (!cend) return (0); c = *p++; } if (c1 >= cstart && c1 <= cend) goto match; if (c == ']') break; } if (!invert) return 0; break; match: /* Skip the rest of the [...] construct that already matched. */ while (c != ']') { if (!c || !(c = *p++)) return (0); if (c == '\\') p++; } if (invert) return 0; break; } default: if (c != *t++) return 0; } } if (*t) return 0; return 1;}/* Like glob_match, but match PATTERN against any final segment of TEXT. */static intglob_match_after_star (pattern, text) char *pattern, *text;{ register char *p = pattern, *t = text; register char c, c1; while ((c = *p++) == '?' || c == '*') { if (c == '?' && *t++ == 0) return 0; } if (c == 0) return 1; if (c == '\\') c1 = *p; else c1 = c; for (;;) { if ((c == '[' || *t == c1) && glob_match (p - 1, t, 0)) return 1; if (*t++ == 0) return 0; }}#ifndef macintosh/* Return a vector of names of files in directory DIR whose names match glob pattern PAT. The names are not in any particular order. Wildcards at the beginning of PAT do not match an initial period. The vector is terminated by an element that is a null pointer. To free the space allocated, first free the vector's elements, then free the vector. Return 0 if cannot get enough memory to hold the pointer and the names. Return -1 if cannot access directory DIR. Look in errno for more information. */char **glob_vector (pat, dir) char *pat; char *dir;{ struct globval { struct globval *next; char *name; }; DIR *d; register struct direct *dp; struct globval *lastlink; register struct globval *nextlink; register char *nextname; int count; int lose; register char **name_vector; register int i; if (!(d = opendir (dir))) return (char **) -1; lastlink = 0; count = 0; lose = 0; /* Scan the directory, finding all names that match. For each name that matches, allocate a struct globval on the stack and store the name in it. Chain those structs together; lastlink is the front of the chain. */ /* Loop reading blocks */ while (1) { dp = readdir (d); if (!dp) break; if (dp->d_ino && glob_match (pat, dp->d_name, noglob_dot_filenames)) { nextlink = (struct globval *) alloca (sizeof (struct globval)); nextlink->next = lastlink; nextname = (char *) malloc (D_NAMLEN(dp) + 1); if (!nextname) { lose = 1; break; } lastlink = nextlink; nextlink->name = nextname; bcopy (dp->d_name, nextname, D_NAMLEN(dp) + 1); count++; } } closedir (d); name_vector = (char **) malloc ((count + 1) * sizeof (char *)); /* Have we run out of memory? */ if (!name_vector || lose) { /* Here free the strings we have got */ while (lastlink) { free (lastlink->name); lastlink = lastlink->next; } return 0; } /* Copy the name pointers from the linked list into the vector */ for (i = 0; i < count; i++) { name_vector[i] = lastlink->name; lastlink = lastlink->next; } name_vector[count] = 0; return name_vector;}/* Return a new array which is the concatenation of each string in ARRAY to DIR. */static char **glob_dir_to_array (dir, array) char *dir, **array;{ register int i, l; int add_slash = 0; char **result; l = strlen (dir); if (!l) return (array); if (dir[l - 1] != '/') add_slash++; for (i = 0; array[i]; i++); result = (char **)malloc ((1 + i) * sizeof (char *)); if (!result) return (result); for (i = 0; array[i]; i++) { result[i] = (char *)malloc (1 + l + add_slash + strlen (array[i])); if (!result[i]) return (char **)NULL; strcpy (result[i], dir); if (add_slash) strcat (result[i], "/"); strcat (result[i], array[i]); } result[i] = (char *)NULL; /* Free the input array. */ for (i = 0; array[i]; i++) free (array[i]); free (array); return (result);}/* Do globbing on PATHNAME. Return an array of pathnames that match, marking the end of the array with a null-pointer as an element. If no pathnames match, then the array is empty (first element is null). If there isn't enough memory, then return NULL. If a file system error occurs, return -1; `errno' has the error code. Wildcards at the beginning of PAT, or following a slash, do not match an initial period. */char **glob_filename (pathname) char *pathname;{ char **result; unsigned int result_size; char *directory_name, *filename; unsigned int directory_len; result = (char **) malloc (sizeof (char *)); result_size = 1; if (result == NULL) return NULL; result[0] = NULL; /* Find the filename. */ filename = rindex (pathname, '/'); if (filename == 0) { filename = pathname; directory_name = ""; directory_len = 0; } else { directory_len = filename - pathname; directory_name = (char *) alloca (directory_len + 1); bcopy (pathname, directory_name, directory_len); directory_name[directory_len] = '\0'; ++filename; } if (glob_tilde && *pathname == '~') { if (directory_len == 0) { filename = directory_name; directory_name = pathname; directory_len = strlen (directory_name); } if (directory_len == 1) { extern char *getenv (); static char *home_directory = 0; static unsigned int home_len; if (home_directory == 0) { home_directory = getenv ("HOME"); if (home_directory == NULL) { home_directory == ""; home_len = 0; } else home_len = strlen (home_directory); } directory_name = home_directory; directory_len = home_len; } else { struct passwd *pwent = getpwnam (directory_name + 1); if (pwent == 0) { directory_name = ""; directory_len = 0; } else { directory_name = pwent->pw_dir; directory_len = strlen (directory_name); } } } else if (glob_pattern_p (directory_name)) { /* If directory_name contains globbing characters, then we have to expand the previous levels. Just recurse. */ char **directories; register unsigned int i; if (directory_name[directory_len - 1] == '/') directory_name[directory_len - 1] = '\0'; directories = glob_filename (directory_name); if (directories == NULL) goto memory_error; else if ((int) directories == -1) return (char **) -1; else if (*directories == NULL) { free ((char *) directories); return (char **) -1; } /* We have successfully globbed the preceding directory name. For each name in DIRECTORIES, call glob_vector on it and FILENAME. Concatenate the results together. */ for (i = 0; directories[i] != NULL; ++i) { char **temp_results = glob_vector (filename, directories[i]); if (temp_results == NULL) goto memory_error; else if ((int) temp_results == -1) /* This filename is probably not a directory. Ignore it. */ ; else { char **array = glob_dir_to_array (directories[i], temp_results); register unsigned int l = 0; while (array[l] != NULL) ++l; esult = (char **) realloc (result, (result_size + 1) * sizeof (char *)); if (result == NULL) goto memory_error; for (l = 0; array[l] != NULL; ++l) result[result_size++ - 1] = array[l]; result[result_size - 1] = NULL; free ((char *) array); } } /* Free the directories. */ for (i = 0; directories[i]; i++) free (directories[i]); free ((char *) directories); return result; } if (*filename == '\0') { /* If there is only a directory name, return it. */ result = (char **) realloc ((char *) result, 2 * sizeof (char *)); if (result == NULL) return NULL; result[0] = (char *) malloc (directory_len + 1); if (result[0] == NULL) goto memory_error; bcopy (directory_name, result[0], directory_len + 1); result[1] = NULL; return result; } else { /* Otherwise, just return what glob_vector returns appended to the directory name. */ char **temp_results = glob_vector (filename, (directory_len == 0 ? "." : directory_name)); if (temp_results == NULL || (int) temp_results == -1) return temp_results; return glob_dir_to_array (directory_name, temp_results); } memory_error:; if (result != NULL) { register unsigned int i; for (i = 0; result[i] != NULL; ++i) free (result[i]); free ((char *) result); } return NULL;}#ifdef TESTmain (argc, argv) int argc; char **argv;{ char **value; int i, index = 1; while (index < argc) { value = glob_filename (argv[index]); if ((int) value == 0) printf ("Memory exhausted.\n"); else if ((int) value == -1) perror (argv[index]); else for (i = 0; value[i]; i++) printf ("%s\n", value[i]); index++; } return 0;}#endif /* TEST */#endif macintosh :MPW:MPW Tools:Tools with Source:gnu sed ƒ:READ ME FIRST!!!
This is a quick port of gnu sed to the MPW 3.1 environment. All source changes arebracketed by #ifdef macintosh directives. Since I have been too lazy to learnthe unix file system I have disabled the w and r options. If someone can fix thisplease let me know. Send Mac specific bug reports to Mat Marcus atAppleLink D3870Internet lynx@belch.berkeley.edu Other gnu->mpw ports: ar bison compress flex gawk gnuchess gnu-go (in progress) grep/egrep libg++ (in progress)Other available unix ports: tar (standalone app) compress (standalone app) ### Contents 'READ ME FIRST!!!' #this file# these (non-gnu) files are useful in a wide variety of unix->mac porting efforts alloca.c #a c version of alloca (stack based malloc) att.getopt.c #a public domain version of getopt# these files are useful in a wide variety of unix->mac porting efforts regex.c regex.h# these are the sed specific files glob.c sed.c unixMakefile # not used unixREADME #not used # these are the sed specific files sed.make #mac makefile sed.man #user manual# here is an 881 compiled verion sed #compiled MPW 3.1 tool (requires 881/020) :MPW:MPW Tools:Tools with Source:gnu sed ƒ:regex.c
/* Extended regular expression matching and search. Copyright (C) 1985 Free Software Foundation, Inc. NO WARRANTY BECAUSE THIS PROGRAM IS LICENSED FREE OF CHARGE, WE PROVIDE ABSOLUTELYNO WARRANTY, TO THE EXTENT PERMITTED BY APPLICABLE STATE LAW. EXCEPTWHEN OTHERWISE STATED IN WRITING, FREE SOFTWARE FOUNDATION, INC,RICHARD M. STALLMAN AND/OR OTHER PARTIES PROVIDE THIS PROGRAM "AS IS"WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING,BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY ANDFITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITYAND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVEDEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR ORCORRECTION. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW WILL RICHARD M.STALLMAN, THE FREE SOFTWARE FOUNDATION, INC., AND/OR ANY OTHER PARTYWHO MAY MODIFY AND REDISTRIBUTE THIS PROGRAM AS PERMITTED BELOW, BELIABLE TO YOU FOR DAMAGES, INCLUDING ANY LOST PROFITS, LOST MONIES, OROTHER SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THEUSE OR INABILITY TO USE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA ORDATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY THIRD PARTIES ORA FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS) THISPROGRAM, EVEN IF YOU HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCHDAMAGES, OR FOR ANY CLAIM BY ANY OTHER PARTY. GENERAL PUBLIC LICENSE TO COPY 1. You may copy and distribute verbatim copies of this source fileas you receive it, in any medium, provided that you conspicuously andappropriately publish on each copy a valid copyright notice "Copyright(C) 1985 Free Software Foundation, Inc."; and include following thecopyright notice a verbatim copy of the above disclaimer of warrantyand of this License. You may charge a distribution fee for thephysical act of transferring a copy. 2. You may modify your copy or copies of this source file orany portion of it, and copy and distribute such modifications underthe terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains or is a derivative of this program or any part thereof, to be licensed at no charge to all third parties on terms identical to those contained in this License Agreement (except that you may choose to grant more extensive warranty protection to some or all third parties, at your option). c) You may charge a distribution fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee.Mere aggregation of another unrelated program with this program (or itsderivative) on a volume of a storage or distribution medium does not bringthe other program under the scope of these terms. 3. You may copy and distribute this program (or a portion or derivativeof it, under Paragraph 2) in object code or executable form under the termsof Paragraphs 1 and 2 above provided that you also do one of the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal shipping charge) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.)For an executable file, complete source code means all the source code forall modules it contains; but, as a special exception, it need not includesource code for modules which are standard libraries that accompany theoperating system on which the executable file runs. 4. You may not copy, sublicense, distribute or transfer this programexcept as expressly provided under this License Agreement. Any attemptotherwise to copy, sublicense, distribute or transfer this program is void andyour rights to use the program under this License agreement shall beautomatically terminated. However, parties who have received computersoftware programs from you with this License Agreement will not havetheir licenses terminated so long as such parties remain in full compliance. 5. If you wish to incorporate parts of this program in freeprograms whose distribution conditions are different, write to the FreeSoftware Foundation at 675 Mass Ave, Cambridge, MA 02139. We have not yetworked out a simple rule that can be stated here, but we will often permitthis. We will be guided by the two goals of preserving the free status ofall derivatives of our free software and of promoting the sharing and reuse ofsoftware.In other words, you are welcome to use, share and improve this program.You are forbidden to forbid anyone else to use, share and improvewhat you give them. Help stamp out software-hoarding! */#ifdef MSDOS#include <malloc.h>static void init_syntax_once(void );extern int re_set_syntax(int syntax);extern char *re_compile_pattern(char *pattern,int size,struct re_pattern_buffer *bufp);static int store_jump(char *from,char opcode,char *to);static int insert_jump(char op,char *from,char *to,char *current_end);extern void re_compile_fastmap(struct re_pattern_buffer *bufp);extern int re_search(struct re_pattern_buffer *pbufp,char *string,int size,int startpos,int range,struct re_registers *regs);extern int re_search_2(struct re_pattern_buffer *pbufp,char *string1,int size1,char *string2,int size2,int startpos,int range,struct re_registers *regs,int mstop);extern int re_match(struct re_pattern_buffer *pbufp,char *string,int size,int pos,struct re_registers *regs);extern int re_match_2(struct re_pattern_buffer *pbufp,unsigned char *string1,int size1,unsigned char *string2,int size2,int pos,struct re_registers *regs,int mstop);static int bcmp_translate(unsigned char *s1,unsigned char *s2,int len,unsigned char *translate);extern char *re_comp(char *s);extern int re_exec(char *s);#endif/* To test, compile with -Dtest. This Dtestable feature turns this into a self-contained program which reads a pattern, describes how it compiles, then reads a string and searches for it. */#ifdef emacs/* The `emacs' switch turns on certain special matching commands that make sense only in emacs. */#include "config.h"#include "lisp.h"#include "buffer.h"#include "syntax.h"#else /* not emacs */#if defined(USG) || defined(MSDOS)#define bcopy(s,d,n) memcpy(d,s,n)#define bcmp(s1,s2,n) memcmp(s1,s2,n)#define bzero(s,n) memset(s,0,n)#ifdef MSDOS#include <malloc.h>#endif#endif/* Make alloca work the best possible way. */#ifdef __GNUC__#define alloca __builtin_alloca#else#ifdef sparc#include <alloca.h>#endif#endif/* * Define the syntax stuff, so we can do the \<...\> things. */#ifndef Sword /* must be non-zero in some of the tests below... */#define Sword 1#endif#define SYNTAX(c) re_syntax_table[c]#ifdef SYNTAX_TABLEchar *re_syntax_table;#elsestatic char re_syntax_table[256];static voidinit_syntax_once (){ register int c; static int done = 0; if (done) return; bzero (re_syntax_table, sizeof re_syntax_table); for (c = 'a'; c <= 'z'; c++) re_syntax_table[c] = Sword; for (c = 'A'; c <= 'Z'; c++) re_syntax_table[c] = Sword; for (c = '0'; c <= '9'; c++) re_syntax_table[c] = Sword; done = 1;}#endif /* SYNTAX_TABLE */#endif /* not emacs */#include "regex.h"/* Number of failure points to allocate space for initially, when matching. If this number is exceeded, more space is allocated, so it is not a hard limit. */#ifndef NFAILURES#define NFAILURES 80#endif /* NFAILURES *//* width of a byte in bits */#define BYTEWIDTH 8#ifndef SIGN_EXTEND_CHAR#define SIGN_EXTEND_CHAR(x) (x)#endifstatic int obscure_syntax = 0;/* Specify the precise syntax of regexp for compilation. This provides for compatibility for various utilities which historically have different, incompatible syntaxes. The argument SYNTAX is a bit-mask containing the two bits RE_NO_BK_PARENS and RE_NO_BK_VBAR. */intre_set_syntax (syntax){ int ret; ret = obscure_syntax; obscure_syntax = syntax; return ret;}/* re_compile_pattern takes a regular-expression string and converts it into a buffer full of byte commands for matching. PATTERN is the address of the pattern string SIZE is the length of it. BUFP is a struct re_pattern_buffer * which points to the info on where to store the byte commands. This structure contains a char * which points to the actual space, which should have been obtained with malloc. re_compile_pattern may use realloc to grow the buffer space. The number of bytes of commands can be found out by looking in the struct re_pattern_buffer that bufp pointed to, after re_compile_pattern returns.*/#define PATPUSH(ch) (*b++ = (char) (ch))#define PATFETCH(c) \ {if (p == pend) goto end_of_pattern; \ c = * (unsigned char *) p++; \ if (translate) c = translate[c]; }#define PATFETCH_RAW(c) \ {if (p == pend) goto end_of_pattern; \ c = * (unsigned char *) p++; }#define PATUNFETCH p--#ifdef MSDOS#define MaxAllocation (1<<14)#else#define MaxAllocation (1<<16)#endif/* The pointer math version is inappropriate for large model, as realloc could move stuff off into a different segment somewhere, in which case the pointer offsets would be wrong. At least that's how I think I understand it - ADR. */#ifndef M_I86LM#define EXTEND_BUFFER \ { char *old_buffer = bufp->buffer; \ if (bufp->allocated == MaxAllocation) goto too_big; \ bufp->allocated *= 2; \ if (bufp->allocated > MaxAllocation) bufp->allocated = MaxAllocation; \ if (!(bufp->buffer = (char *) realloc (bufp->buffer, bufp->allocated))) \ goto memory_exhausted; \ c = bufp->buffer - old_buffer; \ b += c; \ if (fixup_jump) \ fixup_jump += c; \ if (laststart) \ laststart += c; \ begalt += c; \ if (pending_exact) \ pending_exact += c; \ }#else#define EXTEND_BUFFER \ { unsigned b_off = b - bufp->buffer, \ f_off, l_off, p_off, \ beg_off = begalt - bufp->buffer; \ if (fixup_jump) \ f_off = fixup_jump - bufp->buffer; \ if (laststart) \ l_off = laststart - bufp->buffer; \ if (pending_exact) \ p_off = pending_exact - bufp->buffer; \ if (bufp->allocated == MaxAllocation) goto too_big; \ bufp->allocated *= 2; \ if (bufp->allocated > MaxAllocation) bufp->allocated = MaxAllocation; \ if (!(bufp->buffer = (char *) realloc (bufp->buffer, bufp->allocated))) \ goto memory_exhausted; \ b = bufp->buffer + b_off; \ if (fixup_jump) \ fixup_jump = bufp->buffer + f_off; \ if (laststart) \ laststart = bufp->buffer + l_off; \ begalt = bufp->buffer + beg_off; \ if (pending_exact) \ pending_exact = bufp->buffer + p_off; \ }#endifstatic int store_jump (), insert_jump ();char *re_compile_pattern (pattern, size, bufp) char *pattern; int size; struct re_pattern_buffer *bufp;{ register char *b = bufp->buffer; register char *p = pattern; char *pend = pattern + size; register unsigned c, c1; char *p1; unsigned char *translate = (unsigned char *) bufp->translate; /* address of the count-byte of the most recently inserted "exactn" command. This makes it possible to tell whether a new exact-match character can be added to that command or requires a new "exactn" command. */ char *pending_exact = 0; /* address of the place where a forward-jump should go to the end of the containing expression. Each alternative of an "or", except the last, ends with a forward-jump of this sort. */ char *fixup_jump = 0; /* address of start of the most recently finished expression. This tells postfix * where to find the start of its operand. */ char *laststart = 0; /* In processing a repeat, 1 means zero matches is allowed */ char zero_times_ok; /* In processing a repeat, 1 means many matches is allowed */ char many_times_ok; /* address of beginning of regexp, or inside of last \( */ char *begalt = b; /* Stack of information saved by \( and restored by \). Four stack elements are pushed by each \(: First, the value of b. Second, the value of fixup_jump. Third, the value of regnum. Fourth, the value of begalt. */ int stackb[40]; int *stackp = stackb; int *stacke = stackb + 40; int *stackt; /* Counts \('s as they are encountered. Remembered for the matching \), where it becomes the "register number" to put in the stop_memory command */ int regnum = 1; bufp->fastmap_accurate = 0;#ifndef emacs#ifndef SYNTAX_TABLE /* * Initialize the syntax table. */ init_syntax_once();#endif#endif if (bufp->allocated == 0) { bufp->allocated = 28; if (bufp->buffer) /* EXTEND_BUFFER loses when bufp->allocated is 0 */ bufp->buffer = (char *) realloc (bufp->buffer, 28); else /* Caller did not allocate a buffer. Do it for him */ bufp->buffer = (char *) malloc (28); if (!bufp->buffer) goto memory_exhausted; begalt = b = bufp->buffer; } while (p != pend) { if (b - bufp->buffer > bufp->allocated - 10) /* Note that EXTEND_BUFFER clobbers c */ EXTEND_BUFFER; PATFETCH (c); switch (c) { case '$': if (obscure_syntax & RE_TIGHT_VBAR) { if (! (obscure_syntax & RE_CONTEXT_INDEP_OPS) && p != pend) goto normal_char; /* Make operand of last vbar end before this `$'. */ if (fixup_jump) store_jump (fixup_jump, jump, b); fixup_jump = 0; PATPUSH (endline); break; } /* $ means succeed if at end of line, but only in special contexts. If randomly in the middle of a pattern, it is a normal character. */ if (p == pend || *p == '\n' || (obscure_syntax & RE_CONTEXT_INDEP_OPS) || (obscure_syntax & RE_NO_BK_PARENS ? *p == ')' : *p == '\\' && p[1] == ')') || (obscure_syntax & RE_NO_BK_VBAR ? *p == '|' : *p == '\\' && p[1] == '|')) { PATPUSH (endline); break; } goto normal_char; case '^': /* ^ means succeed if at beg of line, but only if no preceding pattern. */ if (laststart && p[-2] != '\n' && ! (obscure_syntax & RE_CONTEXT_INDEP_OPS)) goto normal_char; if (obscure_syntax & RE_TIGHT_VBAR) { if (p != pattern + 1 && ! (obscure_syntax & RE_CONTEXT_INDEP_OPS)) goto normal_char; PATPUSH (begline); begalt = b; } else PATPUSH (begline); break; case '+': case '?': if (obscure_syntax & RE_BK_PLUS_QM) goto normal_char; handle_plus: case '*': /* If there is no previous pattern, char not special. */ if (!laststart && ! (obscure_syntax & RE_CONTEXT_INDEP_OPS)) goto normal_char; /* If there is a sequence of repetition chars, collapse it down to equivalent to just one. */ zero_times_ok = 0; many_times_ok = 0; while (1) { zero_times_ok |= c != '+'; many_times_ok |= c != '?'; if (p == pend) break; PATFETCH (c); if (c == '*') ; else if (!(obscure_syntax & RE_BK_PLUS_QM) && (c == '+' || c == '?'))
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:gnu sed ƒ:regex.c
+++++ Continued from previous card +++++
; else if ((obscure_syntax & RE_BK_PLUS_QM) && c == '\\') { int c1; PATFETCH (c1); if (!(c1 == '+' || c1 == '?')) { PATUNFETCH; PATUNFETCH; break; } c = c1; } else { PATUNFETCH; break; } } /* Star, etc. applied to an empty pattern is equivalent to an empty pattern. */ if (!laststart) break; /* Now we know whether 0 matches is allowed, and whether 2 or more matches is allowed. */ if (many_times_ok) { /* If more than one repetition is allowed, put in a backward jump at the end. */ store_jump (b, maybe_finalize_jump, laststart - 3); b += 3; } insert_jump (on_failure_jump, laststart, b + 3, b); pending_exact = 0; b += 3; if (!zero_times_ok) { /* At least one repetition required: insert before the loop a skip over the initial on-failure-jump instruction */ insert_jump (dummy_failure_jump, laststart, laststart + 6, b); b += 3; } break; case '.': laststart = b; PATPUSH (anychar); break; case '[': while (b - bufp->buffer > bufp->allocated - 3 - (1 << BYTEWIDTH) / BYTEWIDTH) /* Note that EXTEND_BUFFER clobbers c */ EXTEND_BUFFER; laststart = b; if (*p == '^') PATPUSH (charset_not), p++; else PATPUSH (charset); p1 = p; PATPUSH ((1 << BYTEWIDTH) / BYTEWIDTH); /* Clear the whole map */ bzero (b, (1 << BYTEWIDTH) / BYTEWIDTH); /* Read in characters and ranges, setting map bits */ while (1) { PATFETCH (c); /* If awk, \ escapes a ] when inside [...]. */ if ((obscure_syntax & RE_AWK_CLASS_HACK) && c == '\\' && *p == ']') { PATFETCH(c1); b[c1 / BYTEWIDTH] |= 1 << (c1 % BYTEWIDTH); continue; } if (c == ']' && p != p1 + 1) break; if (*p == '-' && p[1] != ']') { PATFETCH (c1); PATFETCH (c1); while (c <= c1) b[c / BYTEWIDTH] |= 1 << (c % BYTEWIDTH), c++; } else { b[c / BYTEWIDTH] |= 1 << (c % BYTEWIDTH); } } /* Discard any bitmap bytes that are all 0 at the end of the map. Decrement the map-length byte too. */ while ((int) b[-1] > 0 && b[b[-1] - 1] == 0) b[-1]--; b += b[-1]; break; case '(': if (! (obscure_syntax & RE_NO_BK_PARENS)) goto normal_char; else goto handle_open; case ')': if (! (obscure_syntax & RE_NO_BK_PARENS)) goto normal_char; else goto handle_close; case '\n': if (! (obscure_syntax & RE_NEWLINE_OR)) goto normal_char; else goto handle_bar; case '|': if (! (obscure_syntax & RE_NO_BK_VBAR)) goto normal_char; else goto handle_bar; case '\\': if (p == pend) goto invalid_pattern; PATFETCH_RAW (c); switch (c) { case '(': if (obscure_syntax & RE_NO_BK_PARENS) goto normal_backsl; handle_open: if (stackp == stacke) goto nesting_too_deep; if (regnum < RE_NREGS) { PATPUSH (start_memory); PATPUSH (regnum); } *stackp++ = b - bufp->buffer; *stackp++ = fixup_jump ? fixup_jump - bufp->buffer + 1 : 0; *stackp++ = regnum++; *stackp++ = begalt - bufp->buffer; fixup_jump = 0; laststart = 0; begalt = b; break; case ')': if (obscure_syntax & RE_NO_BK_PARENS) goto normal_backsl; handle_close: if (stackp == stackb) goto unmatched_close; begalt = *--stackp + bufp->buffer; if (fixup_jump) store_jump (fixup_jump, jump, b); if (stackp[-1] < RE_NREGS) { PATPUSH (stop_memory); PATPUSH (stackp[-1]); } stackp -= 2; fixup_jump = 0; if (*stackp) fixup_jump = *stackp + bufp->buffer - 1; laststart = *--stackp + bufp->buffer; break; case '|': if (obscure_syntax & RE_NO_BK_VBAR) goto normal_backsl; handle_bar: insert_jump (on_failure_jump, begalt, b + 6, b); pending_exact = 0; b += 3; if (fixup_jump) store_jump (fixup_jump, jump, b); fixup_jump = b; b += 3; laststart = 0; begalt = b; break;#ifdef emacs case '=': PATPUSH (at_dot); break; case 's': laststart = b; PATPUSH (syntaxspec); PATFETCH (c); PATPUSH (syntax_spec_code[c]); break; case 'S': laststart = b; PATPUSH (notsyntaxspec); PATFETCH (c); PATPUSH (syntax_spec_code[c]); break;#endif /* emacs */ case 'w': laststart = b; PATPUSH (wordchar); break; case 'W': laststart = b; PATPUSH (notwordchar); break; case '<': PATPUSH (wordbeg); break; case '>': PATPUSH (wordend); break; case 'b': PATPUSH (wordbound); break; case 'B': PATPUSH (notwordbound); break; case '`': PATPUSH (begbuf); break; case '\'': PATPUSH (endbuf); break; case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': c1 = c - '0'; if (c1 >= regnum) goto normal_char; for (stackt = stackp - 2; stackt > stackb; stackt -= 4) if (*stackt == c1) goto normal_char; laststart = b; PATPUSH (duplicate); PATPUSH (c1); break; case '+': case '?': if (obscure_syntax & RE_BK_PLUS_QM) goto handle_plus; default: normal_backsl: /* You might think it would be useful for \ to mean not to translate; but if we don't translate it it will never match anything. */ if (translate) c = translate[c]; goto normal_char; } break; default: normal_char: if (!pending_exact || pending_exact + *pending_exact + 1 != b || *pending_exact == 0177 || *p == '*' || *p == '^' || ((obscure_syntax & RE_BK_PLUS_QM) ? *p == '\\' && (p[1] == '+' || p[1] == '?') : (*p == '+' || *p == '?'))) { laststart = b; PATPUSH (exactn); pending_exact = b; PATPUSH (0); } PATPUSH (c); (*pending_exact)++; } } if (fixup_jump) store_jump (fixup_jump, jump, b); if (stackp != stackb) goto unmatched_open; bufp->used = b - bufp->buffer; return 0; invalid_pattern: return "Invalid regular expression"; unmatched_open: return "Unmatched \\("; unmatched_close: return "Unmatched \\)"; end_of_pattern: return "Premature end of regular expression"; nesting_too_deep: return "Nesting too deep"; too_big: return "Regular expression too big"; memory_exhausted: return "Memory exhausted";}/* Store where `from' points a jump operation to jump to where `to' points. `opcode' is the opcode to store. */static intstore_jump (from, opcode, to) char *from, *to; char opcode;{ from[0] = opcode; from[1] = (to - (from + 3)) & 0377; from[2] = (to - (from + 3)) >> 8;}/* Open up space at char FROM, and insert there a jump to TO. CURRENT_END gives te end of the storage no in use, so we know how much data to copy up. OP is the opcode of the jump to insert. If you call this function, you must zero out pending_exact. */static intinsert_jump (op, from, to, current_end) char op; char *from, *to, *current_end;{ register char *pto = current_end + 3; register char *pfrom = current_end; while (pfrom != from) *--pto = *--pfrom; store_jump (from, op, to);}/* Given a pattern, compute a fastmap from it. The fastmap records which of the (1 << BYTEWIDTH) possible characters can start a string that matches the pattern. This fastmap is used by re_search to skip quickly over totally implausible text. The caller must supply the address of a (1 << BYTEWIDTH)-byte data area as bufp->fastmap. The other components of bufp describe the pattern to be used. */voidre_compile_fastmap (bufp) struct re_pattern_buffer *bufp;{ unsigned char *pattern = (unsigned char *) bufp->buffer; int size = bufp->used; register char *fastmap = bufp->fastmap; register unsigned char *p = pattern; register unsigned char *pend = pattern + size; register int j, k; unsigned char *translate = (unsigned char *) bufp->translate; unsigned char *stackb[NFAILURES]; unsigned char **stackp = stackb; bzero (fastmap, (1 << BYTEWIDTH)); bufp->fastmap_accurate = 1; bufp->can_be_null = 0; while (p) { if (p == pend) { bufp->can_be_null = 1; break; }#ifdef SWITCH_ENUM_BUG switch ((int) ((enum regexpcode) *p++))#else switch ((enum regexpcode) *p++)#endif { case exactn: if (translate) fastmap[translate[p[1]]] = 1; else fastmap[p[1]] = 1; break; case begline: case before_dot: case at_dot: case after_dot: case begbuf: case endbuf: case wordbound: case notwordbound: case wordbeg: case wordend: continue; case endline: if (translate) fastmap[translate['\n']] = 1; else fastmap['\n'] = 1; if (bufp->can_be_null != 1) bufp->can_be_null = 2; break; case finalize_jump: case maybe_finalize_jump: case jump: case dummy_failure_jump: bufp->can_be_null = 1; j = *p++ & 0377; j += SIGN_EXTEND_CHAR (*(char *)p) << 8; p += j + 1; /* The 1 compensates for missing ++ above */ if (j > 0) continue; /* Jump backward reached implies we just went through the body of a loop and matched nothing. Opcode jumped to should be an on_failure_jump. Just treat it like an ordinary jump. For a * loop, it has pushed its failure point already; if so, discard that as redundant. */ if ((enum regexpcode) *p != on_failure_jump) continue; p++; j = *p++ & 0377; j += SIGN_EXTEND_CHAR (*(char *)p) << 8; p += j + 1; /* The 1 compensates for missing ++ above */ if (stackp != stackb && *stackp == p) stackp--; continue; case on_failure_jump: j = *p++ & 0377; j += SIGN_EXTEND_CHAR (*(char *)p) << 8; p++; *++stackp = p + j; continue; case start_memory: case stop_memory: p++; continue; case duplicate: bufp->can_be_null = 1; fastmap['\n'] = 1; case anychar: for (j = 0; j < (1 << BYTEWIDTH); j++) if (j != '\n') fastmap[j] = 1; if (bufp->can_be_null) return; /* Don't return; check the alternative paths so we can set can_be_null if appropriate. */ break; case wordchar: for (j = 0; j < (1 << BYTEWIDTH); j++) if (SYNTAX (j) == Sword) fastmap[j] = 1; break; case notwordchar: for (j = 0; j < (1 << BYTEWIDTH); j++) if (SYNTAX (j) != Sword) fastmap[j] = 1; break;#ifdef emacs case syntaxspec: k = *p++; for (j = 0; j < (1 << BYTEWIDTH); j++) if (SYNTAX (j) == (enum syntaxcode) k) fastmap[j] = 1; break; case notsyntaxspec: k = *p++; for (j = 0; j < (1 << BYTEWIDTH); j++) if (SYNTAX (j) != (enum syntaxcode) k) fastmap[j] = 1; break;#endif /* emacs */ case charset: for (j = *p++ * BYTEWIDTH - 1; j >= 0; j--) if (p[j / BYTEWIDTH] & (1 << (j % BYTEWIDTH))) { if (translate) fastmap[translate[j]] = 1; else fastmap[j] = 1; } break; case charset_not: /* Chars beyond end of map must be allowed */ for (j = *p * BYTEWIDTH; j < (1 << BYTEWIDTH); j++) if (translate) fastmap[translate[j]] = 1; else fastmap[j] = 1; for (j = *p++ * BYTEWIDTH - 1; j >= 0; j--) if (!(p[j / BYTEWIDTH] & (1 << (j % BYTEWIDTH)))) { if (translate) fastmap[translate[j]] = 1; else fastmap[j] = 1; } break; } /* Get here means we have successfully found the possible starting characters of one path of the pattern. We need not follow this path any farther. Instead, look at the next alternative remembered in the stack. */ if (stackp != stackb) p = *stackp--; else break; }}/* Like re_search_2, below, but only one string is specified. */intre_search (pbufp, string, size, startpos, range, regs) struct re_pattern_buffer *pbufp; char *string; int size, startpos, range; struct re_registers *regs;{ return re_search_2 (pbufp, 0, 0, string, size, startpos, range, regs, size);}/* Like re_match_2 but tries first a match starting at index STARTPOS, then at STARTPOS + 1, and so on. RANGE is the number of places to try before giving up. If RANGE is negative, the starting positions tried are STARTPOS, STARTPOS - 1, etc. It is up to the caller to make sure that range is not so large as to take the starting position outside of the input strings.The value returned is the position at which the match was found, or -1 if no match was found, or -2 if error (such as failure stack overflow). */intre_search_2 (pbufp, string1, size1, string2, size2, startpos, range, regs, mstop) struct re_pattern_buffer *pbufp; char *string1, *string2; int size1, size2; int startpos; register int range; struct re_registers *regs; int mstop;{ register char *fastmap = pbufp->fastmap; register unsigned char *translate = (unsigned char *) pbufp->translate; int total = size1 + size2; int val; /* Update the fastmap now if not correct already */ if (fastmap && !pbufp->fastmap_accurate) re_compile_fastmap (pbufp); /* Don't waste time in a long search for a pattern that says it is anchored. */ if (pbufp->used > 0 && (enum regexpcode) pbufp->buffer[0] == begbuf && range > 0) { if (startpos > 0) return -1; else range = 1; } while (1) { /* If a fastmap is supplied, skip quickly over characters that cannot possibly be the start of a match. Note, however, that if the pattern can possibly match the null string, we must test it at each starting point so that we take the first null string we get. */ if (fastmap && startpos < total && pbufp->can_be_null != 1) { if (range > 0) { register int lim = 0; register unsigned char *p; int irange = range; if (startpos < size1 && startpos + range >= size1) lim = range - (size1 - startpos); p = ((unsigned char *) &(startpos >= size1 ? string2 - size1 : string1)[startpos]); if (translate) { while (range > lim && !fastmap[translate[*p++]]) range--; } else { while (range > lim && !fastmap[*p++]) range--; } startpos += irange - range; } else { register unsigned char c; if (startpos >= size1) c = string2[startpos - size1]; else c = string1[startpos]; c &= 0xff; if (translate ? !fastmap[translate[c]] : !fastmap[c]) goto advance; } } if (range >= 0 && startpos == total && fastmap && pbufp->can_be_null == 0) return -1; val = re_match_2 (pbufp, string1, size1, string2, size2, startpos, regs, mstop); if (0 <= val) { if (val == -2) return -2; return startpos; }#ifdef C_ALLOCA alloca (0);#endif /* C_ALLOCA */ advance: if (!range) break; if (range > 0) range--, startpos++; else range++, startpos--; } return -1;}#ifndef emacs /* emacs never uses this */intre_match (pbufp, string,os, regs) struct re_pattern_buffer *pbufp; char *string; int size, pos; struct re_registers *regs;{ return re_match_2 (pbufp, 0, 0, string, size, pos, regs, size);}#endif /* emacs *//* Maximum size of failure stack. Beyond this, overflow is an error. */int re_max_failures = 2000;static int bcmp_translate();/* Match the pattern described by PBUFP against data which is the virtual
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:gnu sed ƒ:regex.c
+++++ Continued from previous card +++++
concatenation of STRING1 and STRING2. SIZE1 and SIZE2 are the sizes of the two data strings. Start the match at position POS. Do not consider matching past the position MSTOP. If pbufp->fastmap is nonzero, then it had better be up to date. The reason that the data to match are specified as two components which are to be regarded as concatenated is so this function can be used directly on the contents of an Emacs buffer. -1 is returned if there is no match. -2 is returned if there is an error (such as match stack overflow). Otherwise the value is the length of the substring which was matched. */intre_match_2 (pbufp, string1, size1, string2, size2, pos, regs, mstop) struct re_pattern_buffer *pbufp; unsigned char *string1, *string2; int size1, size2; int pos; struct re_registers *regs; int mstop;{ register unsigned char *p = (unsigned char *) pbufp->buffer; register unsigned char *pend = p + pbufp->used; /* End of first string */ unsigned char *end1; /* End of second string */ unsigned char *end2; /* Pointer just past last char to consider matching */ unsigned char *end_match_1, *end_match_2; register unsigned char *d, *dend; register int mcnt; unsigned char *translate = (unsigned char *) pbufp->translate; /* Failure point stack. Each place that can handle a failure further down the line pushes a failure point on this stack. It consists of two char *'s. The first one pushed is where to resume scanning the pattern; the second pushed is where to resume scanning the strings. If the latter is zero, the failure point is a "dummy". If a failure happens and the innermost failure point is dormant, it discards that failure point and tries the next one. */ unsigned char *initial_stack[2 * NFAILURES]; unsigned char **stackb = initial_stack; unsigned char **stackp = stackb, **stacke = &stackb[2 * NFAILURES]; /* Information on the "contents" of registers. These are pointers into the input strings; they record just what was matched (on this attempt) by some part of the pattern. The start_memory command stores the start of a register's contents and the stop_memory command stores the end. At that point, regstart[regnum] points to the first character in the register, regend[regnum] points to the first character beyond the end of the register, regstart_seg1[regnum] is true iff regstart[regnum] points into string1, and regend_seg1[regnum] is true iff regend[regnum] points into string1. */ unsigned char *regstart[RE_NREGS]; unsigned char *regend[RE_NREGS]; unsigned char regstart_seg1[RE_NREGS], regend_seg1[RE_NREGS]; /* Set up pointers to ends of strings. Don't allow the second string to be empty unless both are empty. */ if (!size2) { string2 = string1; size2 = size1; string1 = 0; size1 = 0; } end1 = string1 + size1; end2 = string2 + size2; /* Compute where to stop matching, within the two strings */ if (mstop <= size1) { end_match_1 = string1 + mstop; end_match_2 = string2; } else { end_match_1 = end1; end_match_2 = string2 + mstop - size1; } /* Initialize \) text positions to -1 to mark ones that no \( or \) has been seen for. */ for (mcnt = 0; mcnt < sizeof (regend) / sizeof (*regend); mcnt++) regend[mcnt] = (unsigned char *) -1; /* `p' scans through the pattern as `d' scans through the data. `dend' is the end of the input string that `d' points within. `d' is advanced into the following input string whenever necessary, but this happens before fetching; therefore, at the beginning of the loop, `d' can be pointing at the end of a string, but it cannot equal string2. */ if (pos <= size1) d = string1 + pos, dend = end_match_1; else d = string2 + pos - size1, dend = end_match_2;/* Write PREFETCH; just before fetching a character with *d. */#define PREFETCH \ while (d == dend) \ { if (dend == end_match_2) goto fail; /* end of string2 => failure */ \ d = string2; /* end of string1 => advance to string2. */ \ dend = end_match_2; } /* This loop loops over pattern commands. It exits by returning from the function if match is complete, or it drops through if match fails at this starting point in the input data. */ while (1) { if (p == pend) /* End of pattern means we have succeeded! */ { /* If caller wants register contents data back, convert it to indices */ if (regs) { regs->start[0] = pos; if (dend == end_match_1) regs->end[0] = d - string1; else regs->end[0] = d - string2 + size1; for (mcnt = 1; mcnt < RE_NREGS; mcnt++) { if (regend[mcnt] == (unsigned char *) -1) { regs->start[mcnt] = -1; regs->end[mcnt] = -1; continue; } if (regstart_seg1[mcnt]) regs->start[mcnt] = regstart[mcnt] - string1; else regs->start[mcnt] = regstart[mcnt] - string2 + size1; if (regend_seg1[mcnt]) regs->end[mcnt] = regend[mcnt] - string1; else regs->end[mcnt] = regend[mcnt] - string2 + size1; } } if (dend == end_match_1) return (d - string1 - pos); else return d - string2 + size1 - pos; } /* Otherwise match next pattern command */#ifdef SWITCH_ENUM_BUG switch ((int) ((enum regexpcode) *p++))#else switch ((enum regexpcode) *p++)#endif { /* \( is represented by a start_memory, \) by a stop_memory. Both of those commands contain a "register number" argument. The text matched within the \( and \) is recorded under that number. Then, \<digit> turns into a `duplicate' command which is followed by the numeric value of <digit> as the register number. */ case start_memory: regstart[*p] = d; regstart_seg1[*p++] = (dend == end_match_1); break; case stop_memory: regend[*p] = d; regend_seg1[*p++] = (dend == end_match_1); break; case duplicate: { int regno = *p++; /* Get which register to match against */ register unsigned char *d2, *dend2; d2 = regstart[regno]; dend2 = ((regstart_seg1[regno] == regend_seg1[regno]) ? regend[regno] : end_match_1); while (1) { /* Advance to next segment in register contents, if necessary */ while (d2 == dend2) { if (dend2 == end_match_2) break; if (dend2 == regend[regno]) break; d2 = string2, dend2 = regend[regno]; /* end of string1 => advance to string2. */ } /* At end of register contents => success */ if (d2 == dend2) break; /* Advance to next segment in data being matched, if necessary */ PREFETCH; /* mcnt gets # consecutive chars to compare */ mcnt = dend - d; if (mcnt > dend2 - d2) mcnt = dend2 - d2; /* Compare that many; failure if mismatch, else skip them. */ if (translate ? bcmp_translate (d, d2, mcnt, translate) : bcmp (d, d2, mcnt)) goto fail; d += mcnt, d2 += mcnt; } } break; case anychar: /* fetch a data character */ PREFETCH; /* Match anything but a newline. */ if ((translate ? translate[*d++] : *d++) == '\n') goto fail; break; case charset: case charset_not: { /* Nonzero for charset_not */ int not = 0; register int c; if (*(p - 1) == (unsigned char) charset_not) not = 1; /* fetch a data character */ PREFETCH; if (translate) c = translate [*d]; else c = *d; if (c < *p * BYTEWIDTH && p[1 + c / BYTEWIDTH] & (1 << (c % BYTEWIDTH))) not = !not; p += 1 + *p; if (!not) goto fail; d++; break; } case begline: if (d == string1 || d[-1] == '\n') break; goto fail; case endline: if (d == end2 || (d == end1 ? (size2 == 0 || *string2 == '\n') : *d == '\n')) break; goto fail; /* "or" constructs ("|") are handled by starting each alternative with an on_failure_jump that points to the start of the next alternative. Each alternative except the last ends with a jump to the joining point. (Actually, each jump except for the last one really jumps to the following jump, because tensioning the jumps is a hassle.) */ /* The start of a stupid repeat has an on_failure_jump that points past the end of the repeat text. This makes a failure point so that, on failure to match a repetition, matching restarts past as many repetitions have been found with no way to fail and look for another one. */ /* A smart repeat is similar but loops back to the on_failure_jump so that each repetition makes another failure point. */ case on_failure_jump: if (stackp == stacke) { unsigned char **stackx; if (stacke - stackb > re_max_failures * 2) return -2; stackx = (unsigned char **) alloca (2 * (stacke - stackb) * sizeof (char *)); bcopy (stackb, stackx, (stacke - stackb) * sizeof (char *)); stackp = stackx + (stackp - stackb); stacke = stackx + 2 * (stacke - stackb); stackb = stackx; } mcnt = *p++ & 0377; mcnt += SIGN_EXTEND_CHAR (*(char *)p) << 8; p++; *stackp++ = mcnt + p; *stackp++ = d; break; /* The end of a smart repeat has an maybe_finalize_jump back. Change it either to a finalize_jump or an ordinary jump. */ case maybe_finalize_jump: mcnt = *p++ & 0377; mcnt += SIGN_EXTEND_CHAR (*(char *)p) << 8; p++; { register unsigned char *p2 = p; /* Compare what follows with the begining of the repeat. If we can establish that there is nothing that they would both match, we can change to finalize_jump */ while (p2 != pend && (*p2 == (unsigned char) stop_memory || *p2 == (unsigned char) start_memory)) p2++; if (p2 == pend) p[-3] = (unsigned char) finalize_jump; else if (*p2 == (unsigned char) exactn || *p2 == (unsigned char) endline) { register int c = *p2 == (unsigned char) endline ? '\n' : p2[2]; register unsigned char *p1 = p + mcnt; /* p1[0] ... p1[2] are an on_failure_jump. Examine what follows that */ if (p1[3] == (unsigned char) exactn && p1[5] != c) p[-3] = (unsigned char) finalize_jump; else if (p1[3] == (unsigned char) charset || p1[3] == (unsigned char) charset_not) { int not = p1[3] == (unsigned char) charset_not; if (c < p1[4] * BYTEWIDTH && p1[5 + c / BYTEWIDTH] & (1 << (c % BYTEWIDTH))) not = !not; /* not is 1 if c would match */ /* That means it is not safe to finalize */ if (!not) p[-3] = (unsigned char) finalize_jump; } } } p -= 2; -1] != (unsigned char) finalize_jump) { p[-1] = (unsigned char) jump; goto nofinalize; } /* The end of a stupid repeat has a finalize-jump back to the start, where another failure point will be made which will point after all the repetitions found so far. */ case finalize_jump: stackp -= 2; case jump: nofinalize: mcnt = *p++ & 0377; mcnt += SIGN_EXTEND_CHAR (*(char *)p) << 8; p += mcnt + 1; /* The 1 compensates for missing ++ above */ break; case dummy_failure_jump: if (stackp == stacke) { unsigned char **stackx = (unsigned char **) alloca (2 * (stacke - stackb) * sizeof (char *)); bcopy (stackb, stackx, (stacke - stackb) * sizeof (char *)); stackp = stackx + (stackp - stackb); stacke = stackx + 2 * (stacke - stackb); stackb = stackx; } *stackp++ = 0; *stackp++ = 0; goto nofinalize; case wordbound: if (d == string1 /* Points to first char */ || d == end2 /* Points to end */ || (d == end1 && size2 == 0)) /* Points to end */ break; if ((SYNTAX (d[-1]) == Sword) != (SYNTAX (d == end1 ? *string2 : *d) == Sword)) break; goto fail; case notwordbound: if (d == string1 /* Points to first char */ || d == end2 /* Points to end */ || (d == end1 && size2 == 0)) /* Points to end */ goto fail; if ((SYNTAX (d[-1]) == Sword) != (SYNTAX (d == end1 ? *string2 : *d) == Sword)) goto fail; break; case wordbeg: if (d == end2 /* Points to end */ || (d == end1 && size2 == 0) /* Points to end */ || SYNTAX (* (d == end1 ? string2 : d)) != Sword) /* Next char not a letter */ goto fail; if (d == string1 /* Points to first char */ || SYNTAX (d[-1]) != Sword) /* prev char not letter */ break; goto fail; case wordend: if (d == string1 /* Points to first char */ || SYNTAX (d[-1]) != Sword) /* prev char not letter */ goto fail; if (d == end2 /* Points to end */ || (d == end1 && size2 == 0) /* Points to end */ || SYNTAX (d == end1 ? *string2 : *d) != Sword) /* Next char not a letter */ break; goto fail;#ifdef emacs case before_dot: if (((d - string2 <= (unsigned) size2) ? d - bf_p2 : d - bf_p1) <= point) goto fail; break; case at_dot: if (((d - string2 <= (unsigned) size2) ? d - bf_p2 : d - bf_p1) == point) goto fail; break; case after_dot: if (((d - string2 <= (unsigned) size2) ? d - bf_p2 : d - bf_p1) >= point) goto fail; break; case wordchar: mcnt = (int) Sword; goto matchsyntax; case syntaxspec: mcnt = *p++; matchsyntax: PREFETCH; if (SYNTAX (*d++) != (enum syntaxcode) mcnt) goto fail; break; case notwordchar: mcnt = (int) Sword; goto matchnotsyntax; case notsyntaxspec: mcnt = *p++; matchnotsyntax: PREFETCH; if (SYNTAX (*d++) == (enum syntaxcode) mcnt) goto fail; break;#else case wordchar: PREFETCH; if (SYNTAX (*d++) == 0) goto fail; break; case notwordchar: PREFETCH; if (SYNTAX (*d++) != 0) goto fail; break;#endif /* not emacs */ case begbuf: if (d == string1) /* Note, d cannot equal string2 */ break; /* unless string1 == string2. */ goto fail; case endbuf: if (d == end2 || (d == end1 && size2 == 0)) break; goto fail; case exactn: /* Match the next few pattern characters exactly. mcnt is how many characters to match. */ mcnt = *p++; if (translate) { do { PREFETCH; if (translate[*d++] != *p++) goto fail; } while (--mcnt); } else { do { PREFETCH; if (*d++ != *p++) goto fail; } while (--mcnt); } break; } continue; /* Successfully matched one pattern command; keep matching */ /* Jump here if any matching operation fails. */ fail: if (stackp != stackb) /* A restart point is known. Restart there and pop it. */ { if (!stackp[-2]) { /* If innermost failure point is dormant, flush it and keep looking */ stackp -= 2; goto fail; } d = *--stackp; p = *--stackp; if (d >= string1 && d <= end1) dend = end_match_1; } else break; /* Matching at this starting point really fails! */ } return -1; /* Failure to match */}static intbcmp_translate (s1, s2, len, translate) unsigned char *s1, *s2; register int len; unsigned char *translate;{ register unsigned char *p1 = s1, *p2 = s2; while (len) { if (translate [*p1++] != translate [*p2++]) return 1; len--; } return 0;}/* Entry points compatible with bsd4.2 regex library */#ifndef emacsstatic struct re_pattern_buffer re_comp_buf;char *re_comp (s) char *s;{ if (!s) { if (!re_comp_buf.buffer) return "No previous regular expression"; return 0; } if (!re_comp_buf.buffer) { if (!(re_comp_buf.buffer = (char *) malloc (200))) return "Memo
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:gnu sed ƒ:regex.c
/* Definitions for data structures callers pass the regex library. Copyright (C) 1985 Free Software Foundation, Inc. NO WARRANTY BECAUSE THIS PROGRAM IS LICENSED FREE OF CHARGE, WE PROVIDE ABSOLUTELYNO WARRANTY, TO THE EXTENT PERMITTED BY APPLICABLE STATE LAW. EXCEPTWHEN OTHERWISE STATED IN WRITING, FREE SOFTWARE FOUNDATION, INC,RICHARD M. STALLMAN AND/OR OTHER PARTIES PROVIDE THIS PROGRAM "AS IS"WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING,BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY ANDFITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITYAND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVEDEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR ORCORRECTION. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW WILL RICHARD M.STALLMAN, THE FREE SOFTWARE FOUNDATION, INC., AND/OR ANY OTHER PARTYWHO MAY MODIFY AND REDISTRIBUTE THIS PROGRAM AS PERMLOW, BELIABLE TO YOU FOR DAMAGES, INCLUDING ANY LOST PROFITS, LOST MONIES, OROTHER SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THEUSE OR INABILITY TO USE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA ORDATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY THIRD PARTIES ORA FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS) THISPROGRAM, EVEN IF YOU HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCHDAMAGES, OR FOR ANY CLAIM BY ANY OTHER PARTY. GENERAL PUBLIC LICENSE TO COPY 1. You may copy and distribute verbatim copies of this source fileas you receive it, in any medium, provided that you conspicuously andappropriately publish on each copy a valid copyright notice "Copyright(C) 1985 Free Software Foundation, Inc."; and include following thecopyright notice a verbatim copy of the above disclaimer of warrantyand of this License. You may charge a distribution fee for thephysical act of transferring a copy. 2. You may modify your copy or copies of this source file orany portion of it, and copy and distribute such modifications underthe terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains or is a derivative of this program or any part thereof, to be licensed at no charge to all third parties on terms identical to those contained in this License Agreement (except that you may choose to grant more extensive warranty protection to some or all third parties, at your option). c) You may charge a distribution fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee.Mere aggregation of another unrelated program with this program (or itsderivative) on a volume of a storage or distribution medium does not bringthe other program under the scope of these terms. 3. You may copy and distribute this program (or a portion or derivativeof it, under Paragraph 2) in object code or executable form under the termsof Paragraphs 1 and 2 above provided that you also do one of the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal shipping charge) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.)For an executable file, complete source code means all the source code forall modules it contains; but, as a special exception, it need not includesource code for modules which are standard libraries that accompany theoperating system on which the executable file runs. 4. You may not copy, sublicense, distribute or transfer this programexcept as expressly provided under this License Agreement. Any attemptotherwise to copy, sublicense, distribute or transfer this program is void andyour rights to use the program under this License agreement shall beautomatically terminated. However, parties who have received computersoftware programs from you with this License Agreement will not havetheir licenses terminated so long as such parties remain in full compliance. 5. If you wish to incorporate parts of this program into other freeprograms whose distribution conditions are different, write to the FreeSoftware Foundation at 675 Mass Ave, Cambridge, MA 02139. We have not yetworked out a simple rule that can be stated here, but we will often permitthis. We will be guided by the two goals of preserving the free status ofall derivatives of our free software and of promoting the sharing and reuse ofsoftware.In other words, you are welcome to use, share and improve this program.You are forbidden to forbid anyone else to use, share and improvewhat you give them. Help stamp out software-hoarding! *//* Define number of parens for which we record the beginnings and ends. This affects how much space the `struct re_registers' type takes up. */#ifndef RE_NREGS#define RE_NREGS 10#endif/* These bits are used in the obscure_syntax variable to choose among alternative regexp syntaxes. *//* 1 means plain parentheses serve as grouping, and backslash parentheses are needed for literal searching. 0 means backslash-parentheses are grouping, and plain parentheses are for literal searching. */#define RE_NO_BK_PARENS 1/* 1 means plain | serves as the "or"-operator, and \| is a literal. 0 means \| serves as the "or"-operator, and | is a literal. */#define RE_NO_BK_VBAR 2/* 0 means plain + or ? serves as an operator, and \+, \? are literals. 1 means \+, \? are operators and plain +, ? are literals. */#define RE_BK_PLUS_QM 4/* 1 means | binds tighter than ^ or $. 0 means the contrary. */#define RE_TIGHT_VBAR 8/* 1 means treat \n as an _OR operator 0 means treat it as a normal character */#define RE_NEWLINE_OR 16/* 0 means that a special characters (such as *, ^, and $) always have their special meaning regardless of the surrounding context. 1 means that special characters may act as normal characters in some contexts. Specifically, this applies to: ^ - only special at the beginning, or after ( or | $ - only special at the end, or before ) or | *, +, ? - only special when not after the beginning, (, or | */#define RE_CONTEXT_INDEP_OPS 32/* 0 means that \ before a ] inside [ and ] is taken as a real \. 1 means that such a \ escapes the following ]. This is a special case for AWK. Other \ inside [ ] seem to work ok. */#define RE_AWK_CLASS_HACK 64/* Now define combinations of bits for the standard possibilities. */#define RE_SYNTAX_AWK (RE_NO_BK_PARENS | RE_NO_BK_VBAR \ | RE_CONTEXT_INDEP_OPS | RE_AWK_CLASS_HACK)#define RE_SYNTAX_EGREP (RE_SYNTAX_AWK | RE_NEWLINE_OR)#define RE_SYNTAX_GREP (RE_BK_PLUS_QM | RE_NEWLINE_OR)#define RE_SYNTAX_EMACS 0/* This data structure is used to represent a compiled pattern. */struct re_pattern_buffer { char *buffer; /* Space holding the compiled pattern commands. */ int allocated; /* Size of space that buffer points to */ int used; /* Length of portion of buffer actually occupied */ char *fastmap; /* Pointer to fastmap, if any, or zero if none. */ /* re_search uses the fastmap, if there is one, to skip quickly over totally implausible characters */ char *translate; /* Translate table to apply to all characters before comparing. Or zero for no translation. The translation is applied to a pattern when it is compiled and to data when it is matched. */ char fastmap_accurate; /* Set to zero when a new pattern is stored, set to one when the fastmap is updated from it. */ char can_be_null; /* Set to one by compiling fastmap if this pattern might match the null string. It does not necessarily match the null string in that case, but if this is zero, it cannot. 2 as value means can match null string but at end of range or before a character listed in the fastmap. */ };/* Structure to store "register" contents data in. Pass the address of such a structure as an argument to re_match, etc., if you want this information back. start[i] and end[i] record the string matched by \( ... \) grouping i, for i from 1 to RE_NREGS - 1. start[0] and end[0] record the entire string matched. */struct re_registers { int start[RE_NREGS]; int end[RE_NREGS]; };/* These are the command codes that appear in compiled regular expressions, one per byte. Some command codes are followed by argument bytes.and code can specify any interpretation whatever for its arguments. Zero-bytes may appear in the compiled regular expression. */enum regexpcode { unused, exactn, /* followed by one byte giving n, and then by n literal bytes */ begline, /* fails unless at beginning of line */ endline, /* fails unless at end of line */ jump, /* followed by two bytes giving relative address to jump to */ on_failure_jump, /* followed by two bytes giving relative address of place to resume at in case of failure. */ finalize_jump, /* Throw away latest failure point and then jump to address. */ maybe_finalize_jump, /* Like jump but finalize if safe to do so. This is used to jump back to the beginning of a repeat. If the command that follows this jump is clearly incompatible with the one at the beginning of the repeat, such that we can be sure that there is no use backtracking out of repetitions already completed, then we finalize. */ dummy_failure_jump, /* jump, and push a dummy failure point. This failure point will be thrown away if an attempt is made to use it for a failure. A + construct makes this before the first repeat. */ anychar, /* matches any one character */ charset, /* matches any one char belonging to specified set. First following byte is # bitmap bytes. Then come bytes for a bit-map saying which chars are in. Bits in each byte are ordered low-bit-first. A character is in the set if its bit is 1. A character too large to have a bit in the map is automatically not in the set */ charset_not, /* similar but match any character that is NOT one of those specified */ start_memory, /* starts remembering the text that is matched and stores it in a memory register. followed by one byte containing the register number. Register numbers must be in the range 0 through NREGS. */ stop_memory, /* stops remembering the text that is matched and stores it in a memory register. followed by one byte containing the register number. Register numbers must be in the range 0 through NREGS. */ duplicate, /* match a duplicate of something remembered. Followed by one byte containing the index of the memory register. */ before_dot, /* Succeeds if before dot */ at_dot, /* Succeeds if at dot */ after_dot, /* Succeeds if after dot */ begbuf, /* Succeeds if at beginning of buffer */ endbuf, /* Succeeds if at end of buffer */ wordchar, /* Matches any word-constituent character */ notwordchar, /* Matches any char that is not a word-constituent */ wordbeg, /* Succeeds if at word beginning */ wordend, /* Succeeds if at word end */ wordbound, /* Succeeds if at a word boundary */ notwordbound, /* Succeeds if not at a word boundary */ syntaxspec, /* Matches any character whose syntax is specified. followed by a byte which contains a syntax code, Sword or such like */ notsyntaxspec /* Matches any character whose syntax differs from the specified. */ };extern char *re_compile_pattern ();/* Is this really advertised? */extern void re_compile_fastmap ();extern int re_search (), re_search_2 ();extern int re_match (), re_match_2 ();/* 4.2 bsd compatibility (yuck) */extern char *re_comp ();extern int re_exec ();#ifdef SYNTAX_TABLEextern char *re_syntax_table;#endif :MPW:MPW Tools:Tools with Source:gnu sed ƒ:sed.c
/* GNU SED, a batch stream editor. Copyright (C) 1989, Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */#include <stdio.h>#include <ctype.h>#include <regex.h>#ifdef macintosh#include <ErrMgr.h>#endif macintosh/* Compile with 'gcc [-g] [-DHAS_UTILS] [-O] -o sed sed.c [-lutils]' *//* Use '-DHAS_UTILS', -lutils if you if you have hack's utils library *//* Add '-I. regex.c' if regex is not in the system include dir/library *//* This is a good idea */char *version_string = "GNU sed version 1.06 (or so)";/* 1.00 Began (thinking about) distributing this file 1.01 Added s/re/rep/[digits] added #n as first line of script added filename globbing added 'l' command All in the name of POSIX 1.02 Fixed 't', 'b', ':' to trim leading spaces and tabs Fixed \\ in replacement of 's' command Added comments 1.03 Fixes from Mike Haertelfor regexps that match the empty string, and for Ritchie stdio (non-sticky EOF) 1.04 Fixed s/re/rep/[number] 1.05 Fixed error in 'r' (now does things in the right order) */#ifdef USG#define bcopy(s, d, n) ((void)memcpy((d),(s), (n)))#endif/* Struct vector is used to describe a chunk of a sed program. There is one vector for the main program, and one for each { } pair. */struct vector { struct sed_cmd *v; int v_length; int v_allocated; struct vector *up_one; struct vector *next_one;};/* Goto structure is used to hold both GOTO's and labels. There are two separate lists, one of goto's, called 'jumps', and one of labels, called 'labels'. the V element points to the descriptor for the program-chunk in which the goto was encountered. the v_index element counts which element of the vector actually IS the goto/label. The first element of the vector is zero. the NAME element is the null-terminated name of the label. next is the next goto/label in the list*/struct sed_label { struct vector *v; int v_index; char *name; struct sed_label *next;};/* ADDR_TYPE is zero for a null address, one if addr_number is valid, or two if addr_regex is valid, three, if the address is '$' Other values are undefined. */#define ADDR_NULL 0#define ADDR_NUM 1#define ADDR_REGEX 2#define ADDR_LAST 3 struct addr { int addr_type; struct re_pattern_buffer *addr_regex; int addr_number;};/* Aflags: If the low order bit is set, a1 has been matched; apply this command until a2 matches. If the next bit is set, apply this command to all lines that DON'T match the address(es). */#define A1_MATCHED_BIT 01#define ADDR_BANG_BIT 02 struct sed_cmd { struct addr a1,a2; int aflags; char cmd; union { /* This structure is used for a, i, and c commands */ struct { char *text; int text_len; } cmd_txt; /* This is used for b and t commands */ struct sed_cmd *label; /* This for r and w commands */ FILE *io_file; /* This for the hairy s command */ /* For the flags var: low order bit means the 'g' option was given, next bit means the 'p' option was given, and the next bit means a 'w' option was given, and wio_file contains the file to write to. */#define S_GLOBAL_BIT 01#define S_PRINT_BIT 02#define S_WRITE_BIT 04#define S_NUM_BIT 010 struct { struct re_pattern_buffer *regx; char *replacement; int replace_length; int flags; int numb; FILE *wio_file; } cmd_regex; /* This for the y command */ unsigned char *translate; /* For { and } */ struct vector *sub; struct sed_label *jump; } x;};/* Sed operates a line at a time. */struct line { char *text; /* Pointer to line allocated by malloc. */ int length; /* Length of text. */ int alloc; /* Allocated space for text. */};/* This structure holds information about files opend by the 'r', 'w', and 's///w' commands. In paticular, it holds the FILE pointer to use, the files name, a flag that is non-zero if the file is being read instead of written. */#define NUM_FPS 32struct { FILE *phile; char *name; int readit;} file_ptrs[NUM_FPS];/* This for all you losing compilers out there that can't handle void * */#ifdef __GNU__#define VOID void#else#define VOID char#endifextern int optind;extern char *optarg;extern int getopt();extern char *memchr();extern VOID *memmove();extern VOID *ck_malloc(),*ck_realloc();extern VOID *init_buffer();extern char *get_buffer();extern FILE *ck_fopen();extern void ck_fclose();extern void ck_fwrite();extern void flush_buffer();extern void add1_buffer();extern char *strdup();struct vector *compile_program();void savchar();struct sed_label *setup_jump();void line_copy();void line_append();void append_pattern_space();void read_file();void execute_program();void compile_regex ();#ifndef HAS_UTILSchar *myname;#elseextern char *myname;#endif/* If set, don't write out the line unless explictly told to */int no_default_output = 0;/* Current input line # */int input_line_number = 0;/* Are we on the last input file? */int last_input_file = 0;/* Have we hit EOF on the last input file? This is used to decide if we have hit the '$' address yet. */int input_EOF = 0;/* non-zero if a quit command has been executed. */int quit_cmd = 0;/* Have we done any replacements lately? This is used by the 't' command. */int replaced = 0;/* How many '{'s are we executing at the moment */int program_depth = 0;/* The complete compiled SED program that we are going to run */struct vector *the_program = 0;/* information about labels and jumps-to-labels. This is used to do the required backpatching after we have compiled all the scripts. */struct sed_label *jumps = 0;struct sed_label *labels = 0;/* The 'current' input line. */struct line line;/* An input line that's been stored by later use by the program */struct line hold;/* A 'line' to append to the current line when it comes time to write it out */struct line append;/* When we're reading a script command from a string, 'prog_start' and 'prog_end' point to the beginning and end of the string. This would allow us to compile script strings that contain nulls, except that script strings are only read from the command line, which is null-terminated */char *prog_start;char *prog_end;/* When we're reading a script command from a string, 'prog_cur' points to the current character in the string */char *prog_cur;/* This is the name of the current script file. It is used for error messages. */char *prog_name;/* This is the current script file. If it is zero, we are reading from a string stored in 'prog_start' instead. If both 'prog_file' and 'prog_start' are zero, we're in trouble! */FILE *prog_file;/* this is the number of the current script line that we're compiling. It is used to give out useful and informative error messages. */int prog_line = 1;/* This is the file pointer that we're currently reading data from. It may be stdin */FILE *input_file;/* If this variable is non-zero at exit, one or more of the input files couldn't be opend. */int bad_input = 0;/* 'an empty regular expression is equivelent to the last regular expression read' so we have to keep track of the last regex used. Here's where we store a pointer to it (it is only malloc()'d once) */struct re_pattern_buffer *last_regex;/* Various error messages we may want to print */static char ONE_ADDR[] = "Command only uses one address";static char NO_ADDR[] = "Command doesn't take any addresses";static char LINE_JUNK[] ="Extra characters after command";static char BAD_EOF[] = "Unexpected End-of-file";static char USAGE[] = "Usage: %s [-n] [-e script...] [-f sfile...] [file...]\n";static char NO_REGEX[] = "No previous regular expression";/* Yes, the main program, which parses arguments, and does the right thing with them, It also inits the temporary storage, etc. */main(argc,argv)char **argv;{int opt; int compiled = 0; struct sed_label *go,*lbl; myname=argv[0]; while((opt=getopt(argc,argv,"ne:f:"))!=EOF) { switch(opt) { case 'n': if(no_default_output) panic(USAGE); no_default_output++; break; case 'e': compile_string(optarg); compiled++; break; case 'f': compile_file(optarg); compiled++; break; } } if(!compiled) { if(argc<=optind) panic("No program to run\n"); compile_string(argv[optind]); optind++; } for(go=jumps;go;go=go->next) { for(lbl=labels;lbl;lbl=lbl->next) if(!strcmp(lbl->name,go->name)) break; if(!lbl) panic("Can't find label for jump to '%s'\n",go->name); go->v->v[go->v_index].x.jump=lbl; } line.length=0; line.alloc=50; line.text=ck_malloc(50); append.length=0; append.alloc=50; append.text=ck_malloc(50); hold.length=0; hold.alloc=50; hold.text=ck_malloc(50); if(argc<=optind) { last_input_file++; read_file("-"); } else while(optind<argc) { if(optind==argc-1) last_input_file++; read_file(argv[optind]); optind++; if(quit_cmd) break; } if(bad_input) exit(2); exit(0);}/* 'str' is a string (from the command line) that contains a sed command. Compile the command, and add it to the end of 'the_program' */compile_string(str)char *str;{ prog_file = 0; prog_line=0; prog_start=prog_cur=str; prog_end=str+strlen(str); the_program=compile_program(the_program);}/* 'str' is the name of a file containing sed commands. Read them in and add them to the end of 'the_program' */compile_file(str)char *str;{ FILE *file; int ch; prog_start=prog_cur=prog_end=0; prog_name=str; prog_line=1; if(str[0]=='-' && str[1]=='\0') prog_file=stdin; else prog_file=ck_fopen(str,"r"); ch=getc(prog_file); if(ch=='#') { ch=getc(prog_file); if(ch=='n') no_default_output++; while(ch!=EOF && ch!='\n') ch=getc(prog_file); } else if(ch!=EOF) ungetc(ch,prog_file); the_program=compile_program(the_program);}#define MORE_CMDS 40/* Read a program (or a subprogram within '{' '}' pairs) in and store the compiled form in *'vector' Return a pointer to the new vector. */struct vector *compile_program(vector)struct vector *vector;{ struct sed_cmd *cur_cmd; int ch; int slash; VOID *b; unsigned char *string; int num;#ifndef macintosh FILE *compile_filename();#endif macintosh if(!vector) { vector=(struct vector *)ck_malloc(sizeof(struct vector)); vector->v=(struct sed_cmd *)ck_malloc(MORE_CMDS*sizeof(struct sed_cmd)); vector->v_allocated=MORE_CMDS; vector->v_length=0; vector->up_one = 0; vector->next_one = 0; } for(;;) { do ch=inchar(); while(ch!=EOF && (isspace(ch) || ch=='\n' || ch==';')); if(ch==EOF) break; savchar(ch); if(vector->v_length==vector->v_allocated) { vector->v=(struct sed_cmd *)ck_realloc((VOID *)vector->v,(vector->v_length+MORE_CMDS)*sizeof(struct sed_cmd)); vector->v_allocated+=MORE_CMDS; } cur_cmd=vector->v+vector->v_length; vector->v_length++; cur_cmd->a1.addr_type=0; cur_cmd->a2.addr_type=0; cur_cmd->aflags=0; cur_cmd->cmd=0; skip_comment: if(compile_address(&(cur_cmd->a1))) { ch=inchar(); if(ch==',') { do ch=inchar(); while(ch!=EOF && isspace(ch)); savchar(ch); if(compile_address(&(cur_cmd->a2))) ; else bad_prog("Unexpected ','"); } else savchar(ch); } ch=inchar(); if(ch==EOF) break; new_cmd: switch(ch) { case '#': if(cur_cmd->a1.addr_type!=0) bad_prog(NO_ADDR); do ch=inchar(); while(ch!=EOF && ch!='\n'); goto skip_comment; case '!': if(cur_cmd->aflags & ADDR_BANG_BIT) bad_prog("Multiple '!'s"); cur_cmd->aflags|= ADDR_BANG_BIT; do ch=inchar(); while(ch!=EOF && isspace(ch)); if(ch==EOF) bad_prog(BAD_EOF); /* savchar(ch); */ goto new_cmd; case 'a': case 'i': if(cur_cmd->a2.addr_type!=0) bad_prog(ONE_ADDR); /* Fall Through */ case 'c': cur_cmd->cmd=ch; if(inchar()!='\\' || inchar()!='\n') bad_prog(LINE_JUNK); b=init_buffer(); while((ch=inchar())!=EOF && ch!='\n') { if(ch=='\\') ch=inchar(); add1_buffer(b,ch); } if(ch!=EOF) add1_buffer(b,ch); num=size_buffer(b); string=(unsigned char *)ck_malloc(num); bcopy(get_buffer(b),string,num); flush_buffer(b); cur_cmd->x.cmd_txt.text_len=num; cur_cmd->x.cmd_txt.text=(char *)string; break; case '{': cur_cmd->cmd=ch; program_depth++; /* while((ch=inchar())!=EOF && ch!='\n') if(!isspace(ch)) bad_prog(LINE_JUNK); */ cur_cmd->x.sub=compile_program((struct vector *)0); /* FOO JF is this the right thing to do? */ break; case '}': if(!program_depth) bad_prog("Unexpected '}'"); --(vector->v_length); while((ch=inchar())!=EOF && ch!='\n' && ch!=';') if(!isspace(ch)) bad_prog(LINE_JUNK); return vector; case ':': cur_cmd->cmd=ch; if(cur_cmd->a1.addr_type!=0) bad_prog(": doesn't want any addresses"); labels=setup_jump(labels,cur_cmd,vector); break; case 'b': case 't': cur_cmd->cmd=ch; jumps=setup_jump(jumps,cur_cmd,vector); break; case 'q': case '=': if(cur_cmd->a2.addr_type) bad_prog(ONE_ADDR); /* Fall Through */ case 'd': case 'D': case 'g': case 'G': case 'h': case 'H': case 'l': case 'n': case 'N': case 'p': case 'P': case 'x': cur_cmd->cmd=ch; do ch=inchar(); while(ch!=EOF && isspace(ch) && ch!='\n' && ch!=';'); if(ch!='\n' && ch!=';' && ch!=EOF) bad_prog(LINE_JUNK); break; case 'r': if(cur_cmd->a2.addr_type!=0) bad_prog(ONE_ADDR); /* FALL THROUGH */#ifndef macintosh case 'w': cur_cmd->cmd=ch; cur_cmd->x.io_file=compile_filename(ch=='r'); break;#endif macintosh case 's': cur_cmd->cmd=ch; slash=inchar(); compile_regex(slash); cur_cmd->x.cmd_regex.regx=last_regex; b=init_buffer(); while((ch=inchar())!=EOF && ch!=slash) { if(ch=='\\') { int ci; ci=inchar(); if(ci!=EOF) { if(ci!='\n') add1_buffer(b,ch); add1_buffer(b,ci); } } else add1_buffer(b,ch); } cur_cmd->x.cmd_regex.replace_length=size_buffer(b); cur_cmd->x.cmd_regex.replacement=ck_malloc(cur_cmd->x.cmd_regex.replace_length); bcopy(get_buffer(b),cur_cmd->x.cmd_regex.replacement,cur_cmd->x.cmd_regex.replace_length); flush_buffer(b); cur_cmd->x.cmd_regex.flags=0; cur_cmd->x.cmd_regex.numb=0; if(ch==EOF) break; do { ch=inchar(); switch(ch) { case 'p': if(cur_cmd->x.cmd_regex.flags&S_PRINT_BIT) bad_prog("multiple 'p' options to 's' command"); cur_cmd->x.cmd_regex.flags|=S_PRINT_BIT; break; case 'g': if(cur_cmd->x.cmd_regex.flags&S_NUM_BIT) cur_cmd->x.cmd_regex.flags&= ~S_NUM_BIT; if(cur_cmd->x.cmd_regex.flags&S_GLOBAL_BIT) bad_prog("multiple 'g' options to 's' command"); cur_cmd->x.cmd_regex.flags|=S_GLOBAL_BIT; break;#ifndef macintosh case 'w': cur_cmd->x.cmd_regex.flags|=S_WRITE_BIT; cur_cmd->x.cmd_regex.wio_file=compile_filename(0); ch='\n'; break;#endif macintosh case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': if(cur_cmd->x.cmd_regex.flags&S_NUM_BIT) bad_pr
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:gnu sed ƒ:sed.c
+++++ Continued from previous card +++++
og("multiple number options to 's' command"); if((cur_cmd->x.cmd_regex.flags&S_GLOBAL_BIT)==0) cur_cmd->x.cmd_regex.flags|=S_NUM_BIT; num = 0; while(isdigit(ch)) { num=num*10+ch-'0'; ch=inchar(); } savchar(ch); cur_cmd->x.cmd_regex.numb=num; break; case '\n': case ';': case EOF: break; default: bad_prog("Unknown option to 's'"); break; } } while(ch!=EOF && ch!='\n' && ch!=';'); if(ch==EOF) break; break; case 'y': cur_cmd->cmd=ch; string=(unsigned char *)ck_malloc(256); for(num=0;num<256;num++) string[num]=num; b=init_buffer(); slash=inchar(); while((ch=inchar())!=EOF && ch!=slash) add1_buffer(b,ch); cur_cmd->x.translate=string; string=(unsigned char *)get_buffer(b); for(num=size_buffer(b);num;--num) { ch=inchar(); if(ch==EOF) bad_prog(BAD_EOF); if(ch==slash) bad_prog("strings for y command are different lengths"); cur_cmd->x.translate[*string++]=ch; } flush_buffer(b); if(inchar()!=slash || ((ch=inchar())!=EOF && ch!='\n' && ch!=';')) bad_prog(LINE_JUNK); break; default: bad_prog("Unknown command"); } } return vector;}/* Complain about a programming error and exit. */bad_prog(why)char *why;{ if(prog_line) fprintf(stderr,"%s: file %s line %d: %s\n",myname,prog_name,prog_line,why); else fprintf(stderr,"%s: %s\n",myname,why); exit(1);}/* Read the next character from the program. Return EOF if there isn't anything to read. Keep prog_line up to date, so error messages can be meaningful. */intinchar(){ int ch; if(prog_file) { if(feof(prog_file)) return EOF; else ch=getc(prog_file); } else { if(!prog_cur) return EOF; else if(prog_cur==prog_end) { ch=EOF; prog_cur=0; } else ch= *prog_cur++; } if(ch=='\n' && prog_line) prog_line++; return ch;}/* unget 'ch' so the next call to inchar will return it. 'ch' must not be EOF or anything nasty like that. */voidsavchar(ch)int ch;{ if(ch==EOF) return; if(ch=='\n' && prog_line>1) --prog_line; if(prog_file) ungetc(ch,prog_file); else *--prog_cur=ch;}/* Try to read an address for a sed command. If it succeeeds, return non-zero and store the resulting address in *'addr'. If the input doesn't look like an address read nothing and return zero. */intcompile_address(addr)struct addr *addr;{ int ch; int num; char *b,*init_buffer(); ch=inchar(); if(isdigit(ch)) { num=ch-'0'; while((ch=inchar())!=EOF && isdigit(ch)) num=num*10+ch-'0'; while(ch!=EOF && isspace(ch)) ch=inchar(); savchar(ch); addr->addr_type=ADDR_NUM; addr->addr_number = num; return 1; } else if(ch=='/') { addr->addr_type=ADDR_REGEX; compile_regex('/'); addr->addr_regex=last_regex; do ch=inchar(); while(ch!=EOF && isspace(ch)); savchar(ch); return 1; } else if(ch=='$') { addr->addr_type=ADDR_LAST; do ch=inchar(); while(ch!=EOF && isspace(ch)); savchar(ch); return 1; } else savchar(ch); return 0;}voidcompile_regex (slash){ VOID *b; int ch; b=init_buffer(); while((ch=inchar())!=EOF && ch!=slash) { if(ch=='^') { if(size_buffer(b)==0) { add1_buffer(b,'\\'); add1_buffer(b,'`'); } else add1_buffer(b,ch); continue; } else if(ch=='$') { ch=inchar(); savchar(ch); if(ch==slash) { add1_buffer(b,'\\'); add1_buffer(b,'\''); } else add1_buffer(b,'$'); continue; } else if(ch!='\\') { add1_buffer(b,ch); continue; } ch=inchar(); switch(ch) { case 'n': add1_buffer(b,'\n'); break; /* case 'b': add1_buffer(b,'\b'); break; case 'f': add1_buffer(b,'\f'); break; case 'r': add1_buffer(b,'\r'); break; case 't': add1_buffer(b,'\t'); break; */ case EOF: break; default: add1_buffer(b,'\\'); add1_buffer(b,ch); break; } } if(ch==EOF) bad_prog(BAD_EOF); if(size_buffer(b)) { last_regex=(struct re_pattern_buffer *)ck_malloc(sizeof(struct re_pattern_buffer)); last_regex->allocated=size_buffer(b); last_regex->buffer=ck_malloc(last_regex->allocated); last_regex->fastmap=0; last_regex->translate=0; re_compile_pattern(get_buffer(b),size_buffer(b),last_regex); } else if(!last_regex) bad_prog(NO_REGEX); flush_buffer(b);}/* Store a label (or label reference) created by a ':', 'b', or 't' comand so that the jump to/from the lable can be backpatched after compilation is complete */struct sed_label *setup_jump(list,cmd,vec)struct sed_label *list;struct sed_cmd *cmd;struct vector *vec;{ struct sed_label *tmp; VOID *b; int ch; b=init_buffer(); while((ch=inchar())==' ' || ch=='\t') ; do add1_buffer(b,ch); while((ch=inchar())!=EOF && ch!='\n'); add1_buffer(b,'\0'); tmp=(struct sed_label *)ck_malloc(sizeof(struct sed_label)); tmp->v=vec; tmp->v_index=cmd-vec->v; tmp->name=strdup(get_buffer(b)); tmp->next=list; flush_buffer(b); return tmp;}#ifndef macintosh/* read in a filename for a 'r', 'w', or 's///w' command, and update the internal structure about files. The file is opened if it isn't already open. */FILE *compile_filename(readit){ char *file_name; int n; VOID *b; int ch; char **globbed; extern char **glob_filename(); if(inchar()!=' ') bad_prog("missing ' ' before filename"); b=init_buffer(); while((ch=inchar())!=EOF && ch!='\n') add1_buffer(b,ch); add1_buffer(b,'\0'); file_name=get_buffer(b); globbed=glob_filename(file_name); if(globbed==0 || globbed==(char **)-1) bad_prog("can't parse filename"); if(globbed[0] && globbed[1]!=0) bad_prog("multiple files"); if(globbed[0]) file_name=globbed[0]; for(n=0;n<NUM_FPS;n++) { if(!file_ptrs[n].name) break; if(!strcmp(file_ptrs[n].name,file_name)) { if(file_ptrs[n].readit!=readit) bad_prog("Can't open file for both reading and writing"); flush_buffer(b); return file_ptrs[n].phile; } } if(n<NUM_FPS) { file_ptrs[n].name=strdup(file_name); file_ptrs[n].readit=readit; file_ptrs[n].phile=ck_fopen(file_name,readit ? "r" : "a"); flush_buffer(b); return file_ptrs[n].phile; } else { bad_prog("Hopelessely evil compiled in limit on number of open files. re-compile sed\n"); return 0; }}#endif macintosh/* Parse a filename given by a 'r' 'w' or 's///w' command. */voidread_file(name)char *name;{ if(*name=='-' && name[1]=='\0') input_file=stdin; else { input_file=fopen(name,"r"); if(input_file==0) { extern int errno;#ifdef macintosh char ptr[256]; bad_input++; fprintf(stderr,"%s: can't read %s: %s\n",myname,name,GetSysErrText(errno, ptr));#else extern char *sys_errlist[]; extern int sys_nerr; char *ptr; ptr=(errno>=0 && errno<sys_nerr) ? sys_errlist[errno] : "Unknown error code"; bad_input++; fprintf(stderr,"%s: can't read %s: %s\n",myname,name,ptr);#endif macintosh return; } } while(read_pattern_space()) { execute_program(the_program); if(!no_default_output) ck_fwrite(line.text,1,line.length,stdout); if(append.length) { ck_fwrite(append.text,1,append.length,stdout); append.length=0; } if(quit_cmd) break; } ck_fclose(input_file);}/* Execute the program 'vec' on the current input line. */voidexecute_program(vec)struct vector *vec;{ struct sed_cmd *cur_cmd; int n; int addr_matched; static int end_cycle; int start; int remain; int offset; static struct line tmp; struct line t; char *rep,*rep_end,*rep_next,*rep_cur; struct re_registers regs; int count = 0; void str_append(); end_cycle = 0; for(cur_cmd=vec->v,n=vec->v_length;n;cur_cmd++,n--) { exe_loop: addr_matched=0; if(cur_cmd->aflags&A1_MATCHED_BIT) { addr_matched=1; if(match_address(&(cur_cmd->a2))) cur_cmd->aflags&=~A1_MATCHED_BIT; } else if(match_address(&(cur_cmd->a1))) { addr_matched=1; if(cur_cmd->a2.addr_type!=ADDR_NULL) cur_cmd->aflags|=A1_MATCHED_BIT; } if(cur_cmd->aflags&ADDR_BANG_BIT) addr_matched= !addr_matched; if(!addr_matched) continue; switch(cur_cmd->cmd) { case '{': /* Execute sub-program */ execute_program(cur_cmd->x.sub); break; case ':': /* Executing labels is easy. */ break; case '=': printf("%d\n",input_line_number); break; case 'a': if(append.alloc-append.length<cur_cmd->x.cmd_txt.text_len) { append.text=ck_realloc(append.text,append.alloc+cur_cmd->x.cmd_txt.text_len); append.alloc+=cur_cmd->x.cmd_txt.text_len; } bcopy(cur_cmd->x.cmd_txt.text,append.text+append.length,cur_cmd->x.cmd_txt.text_len); append.length+=cur_cmd->x.cmd_txt.text_len; break; case 'b': if(!cur_cmd->x.jump) end_cycle++; else { struct sed_label *j = cur_cmd->x.jump; n= j->v->v_length - j->v_index; cur_cmd= j->v->v + j->v_index; goto exe_loop; } brease 'c': line.length=0; if(!(cur_cmd->aflags&A1_MATCHED_BIT)) ck_fwrite(cur_cmd->x.cmd_txt.text,1,cur_cmd->x.cmd_txt.text_len,stdout); end_cycle++; break; case 'd': line.length=0; end_cycle++; break; case 'D': { char *tmp; int newlength; tmp=memchr(line.text,'\n',line.length); newlength=line.length-(tmp-line.text); if(newlength) memmove(line.text,tmp,newlength); line.length=newlength; } end_cycle++; break; case 'g': line_copy(&hold,&line); break; case 'G': line_append(&hold,&line); break; case 'h': line_copy(&line,&hold); break; case 'H': line_append(&line,&hold); break; case 'i': ck_fwrite(cur_cmd->x.cmd_txt.text,1,cur_cmd->x.cmd_txt.text_len,stdout); break; case 'l': { char *tmp; int n; int width = 0; n=line.length; tmp=line.text; /* Use --n so this'll skip the trailing newline */ while(--n) { if(width>77) { width=0; putchar('\n'); } if(isprint(*tmp)) { putchar(*tmp); width++; } else switch(*tmp) { case '\0': printf("\\0"); width+=2; break; case '\a': printf("\\a"); width+=2; break; case '\b': printf("\\b"); width+=2; break; case '\f': printf("\\f"); width+=2; break; case '\n': printf("\\n"); width+=2; break; case '\r': printf("\\r"); width+=2; break; case '\t': printf("\\t"); width+=2; break; case '\v': printf("\\v"); width+=2; break; default: printf("/%02x",(*tmp)&0xFF); width+=2; break; } tmp++; } putchar('\n'); } break; case 'n': ck_fwrite(line.text,1,line.length,stdout); read_pattern_space(); break; case 'N': append_pattern_space(); break; case 'p': ck_fwrite(line.text,1,line.length,stdout); break; case 'P': { char *tmp; tmp=memchr(line.text,'\n',line.length); ck_fwrite(line.text,1,line.length-(tmp-line.text),stdout); } break; case 'q': quit_cmd++; end_cycle++; break; case 'r': { int n; char tmp_buf[1024]; rewind(cur_cmd->x.io_file); while((n=fread(append.tex.length,sizeof(char),append.alloc-append.length,cur_cmd->x.io_file))>0) { append.length += n; if(append.length==append.alloc) { append.text = ck_realloc(append.text, append.alloc + cur_cmd->x.cmd_txt.text_len); append.alloc += cur_cmd->x.cmd_txt.text_len; } } if(ferror(cur_cmd->x.io_file)) panic("Read error on input file to 'r' command\n"); } break; case 's': if(!tmp.alloc) { tmp.alloc=50; tmp.text=ck_malloc(50); } count=0; start = 0; remain=line.length-1; tmp.length=0; rep = cur_cmd->x.cmd_regex.replacement; rep_end=rep+cur_cmd->x.cmd_regex.replace_length; while((offset = re_search(cur_cmd->x.cmd_regex.regx, line.text, line.length-1, start, remain, ®s))>=0) { count++; if(offset-start) str_append(&tmp,line.text+start,offset-start); if(cur_cmd->x.cmd_regex.flags&S_NUM_BIT) { if(count!=cur_cmd->x.cmd_regex.numb) { str_append(&tmp,line.text+regs.start[0],regs.end[0]-regs.start[0]); start = (offset == regs.end[0] ? offset + 1 : regs.end[0]); remain = (line.length-1) - start; continue; } } for(rep_next=rep_cur=rep;rep_next<rep_end;rep_next++) { if(*rep_next=='&') { if(rep_next-rep_cur) str_append(&tmp,rep_cur,rep_next-rep_cur); str_append(&tmp,line.text+regs.start[0],regs.end[0]-regs.start[0]); rep_cur=rep_next+1; } else if(*rep_next=='\\') { if(rep_next-rep_cur) str_append(&tmp,rep_cur,rep_next-rep_cur); rep_next++; if(rep_next!=rep_end) { int n; if(*rep_next>='0' && *rep_next<='9') { n= *rep_next -'0'; str_append(&tmp,line.text+regs.start[n],regs.end[n]-regs.start[n]); } else str_append(&tmp,rep_next,1); } rep_cur=rep_next+1; } } if(rep_next-rep_cur) str_append(&tmp,rep_cur,rep_next-rep_cur); if (offset == regs.end[0]) { str_append(&tmp, line.text + offset, 1); ++regs.end[0]; } start = regs.end[0]; remain = (line.length-1) - start; if(remain<0) break; if(!(cur_cmd->x.cmd_regex.flags&S_GLOBAL_BIT)) break; } if(!count) break; replaced=1; str_append(&tmp,line.text+regs.end[0],line.length-regs.end[0]); t.text=line.text; t.length=line.length; t.alloc=line.alloc; line.text=tmp.text; line.length=tmp.length; line.alloc=tmp.alloc; tmp.text=t.text; tmp.length=t.length; tmp.alloc=t.alloc; if(cur_cmd->x.cmd_regex.flags&S_WRITE_BIT) ck_fwrite(line.text,1,line.length,cur_cmd->x.cmd_regex.wio_file); if(cur_cmd->x.cmd_regex.flags&S_PRINT_BIT) ck_fwrite(line.text,1,line.length,stdout); break; case 't': if(replaced) { replaced = 0; if(!cur_cmd->x.jump) end_cycle++; else { struct sed_label *j = cur_cmd->x.jump; n= j->v->v_length - j->v_index; cur_cmd= j->v->v + j->v_index; goto exe_loop; } } break; case 'w': ck_fwrite(line.text,1,line.length,cur_cmd->x.io_file); break; case 'x': { struct line tmp; tmp=line; line=hold; hold=tmp; } break; case 'y': { unsigned char *p,*e; for(p=(unsigned char *)(line.text),e=p+line.length;p<e;p++) *p=cur_cmd->x.translate[*p]; } break; default: panic("INTERNAL ERROR: Bad cmd %c\n",cur_cmd->cmd); } if(end_cycle) break; }}/* Return non-zero if the current line matches the address pointed to by 'addr'. */match_address(addr)struct addr *addr;{ switch(addr->addr_type) { case ADDR_NULL: return 1; case ADDR_NUM: return (input_line_number==addr->addr_number); case ADDR_REGEX: return (re_search(addr->addr_regex, line.text, line.length-1, 0, line.length-1, 0)>=0) ? 1 : 0; case ADDR_LAST: return (input_EOF) ? 1 : 0; default: panic("INTERNAL ERROR: bad address type\n"); break; } return -1;}/* Read in the next line of input, and store it in the pattern space. Return non-zero if this is the last line of input */intread_pattern_space(){ int n; char *p; int ch; p=line.text; n=line.alloc; if(feof(input_file)) return 0; input_line_number++; replaced=0; for(;;) { ch=getc(input_file); if(ch==EOF) { if(n==line.alloc) return 0; *p++='\n'; --n; line.length=line.alloc-n; if(last_input_file) input_EOF++; return 1; } *p++=ch; --n; if(ch=='\n') { line.length=line.alloc-n; break; } if(n==0) { line.text=ck_realloc(line.text,line.alloc*2); p=line.text+line.alloc; n=line.alloc; line.alloc*=2; } } ch=getc(input_file); if(ch!=EOF) ungetc(ch,input
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:gnu sed ƒ:sed.c
+++++ Continued from previous card +++++
_file); else if(last_input_file) input_EOF++; return 1;}/* Inplement the 'N' command, which appends the next line of input to the pattern space. */voidappend_pattern_space(){ char *p; int n; int ch; p=line.text+line.length; n=line.alloc-line.length; input_line_number++; replaced=0; if(feof(input_file)) return; for(;;) { ch=getc(input_file); if(ch==EOF) { if(n==line.alloc) return; *p++='\n'; --n; line.length=line.alloc-n; if(last_input_file) input_EOF++; return; } *p++=ch; --n; if(ch=='\n') { line.length=line.alloc-n; break; } if(n==0) { line.text=ck_realloc(line.text,line.alloc*2); p=line.text+line.alloc; n=line.alloc; line.alloc*=2; } } ch=getc(input_file); if(ch!=EOF) ungetc(ch,input_file); else if(last_input_file) input_EOF++;}/* Copy the contents of the line 'from' into the line 'to'. This destroys the old contents of 'to'. It will still work if the line 'from' contains nulls. */voidline_copy(from,to)struct line *from,*to;{ if(from->length>to->alloc) { to->alloc=from->length; to->text=ck_realloc(to->text,to->alloc); } bcopy(from->text,to->text,from->length); to->length=from->length;}/* Append the contents of the line 'from' to the line 'to'. This routine will work even if the line 'from' contains nulls */voidline_append(from,to)struct line *from,*to;{ if(from->length>(to->alloc-to->length)) { to->alloc+=from->length; to->text=ck_realloc(to->text,to->alloc); } bcopy(from->text,to->text+to->length,from->length); to->length+=from->length;}/* Append 'length' bytes from 'string' to the line 'to' This routine *will* append bytes with nulls in them, without failing. */voidstr_append(to,string,length)struct line *to;char *string;int length;{ if(length>to->alloc-to->length) { to->alloc+=length; to->text=ck_realloc(to->text,to->alloc); } bcopy(string,to->text+to->length,length); to->length+=length;}#ifndef HAS_UTILS/* These routines were written as part of a library (by me), but since most people don't have the library, here they are. */#ifdef __STDC__#include "stdarg.h"/* Print an error message and exit */panic(str)char *str;{ va_list iggy; va_start(iggy,str); fprintf(stderr,"%s: ",myname);#ifdef NO_VFPRINTF _doprnt(str,&iggy,stderr);#else vfprintf(stderr,str,iggy);#endif putc('\n',stderr); va_end(iggy); exit(4);}#else#include "varargs.h"panic(str,va_alist)char *str;va_dcl{ va_list iggy; va_start(iggy); fprintf(stderr,"%s: ",myname);#ifdef NO_VFPRINTF _doprnt(str,&iggy,stderr);#else vfprintf(stderr,str,iggy);#endif putc('\n',stderr); va_end(iggy); exit(4);}#endif/* Store information about files opened with ck_fopen so that error messages from ck_fread, etc can print the name of the file that had the error */#define N_FILE 32struct id { FILE *fp; char *name;};static struct id __id_s[N_FILE];/* Internal routine to get a filename from __id_s */char *__fp_name(fp)FILE *fp;{ int n; for(n=0;n<N_FILE;n++) { if(__id_s[n].fp==fp) return __id_s[n].name; } return "{Unknown file pointer}";}/* Panic on failing fopen */FILE *ck_fopen(name,mode)char *name;char *mode;{ FILE *ret; int n; ret=fopen(name,mode); if(ret==(FILE *)0) panic("Couldn't open file %s\n",name); for(n=0;n<N_FILE;n++) { if(ret==__id_s[n].fp) { free((VOID *)__id_s[n].name); __id_s[n].name=(char *)ck_malloc(strlen(name)+1); strcpy(__id_s[n].name,name); break; } } if(n==N_FILE) { for(n=0;n<N_FILE;n++) if(__id_s[n].fp==(FILE *)0) break; if(n==N_FILE) panic("Internal error: too many files open\n"); __id_s[n].fp=ret; __id_s[n].name=(char *)ck_malloc(strlen(name)+1); strcpy(__id_s[n].name,name); } return ret;}/* Panic on failing fwrite */voidck_fwrite(ptr,size,nmemb,stream)char *ptr;int size,nmemb;FILE *stream;{ if(fwrite(ptr,size,nmemb,stream)!=nmemb) panic("couldn't write %d items to %s",nmemb,__fp_name(stream));}/* Panic on failing fclose */voidck_fclose(stream)FILE *stream;{ if(fclose(stream)==EOF) panic("Couldn't close %s\n",__fp_name(stream));}/* Panic on failing malloc */VOID *ck_malloc(size)int size;{ VOID *ret; VOID *malloc(); ret=malloc(size); if(ret==(VOID *)0) panic("Couldn't allocate memory\n"); return ret;}/* Panic on failing realloc */VOID *ck_realloc(ptr,size)VOID *ptr;int size;{ VOID *ret; VOID *realloc(); ret=realloc(ptr,size); if(ret==(VOID *)0) panic("Couldn't re-allocate memory\n"); return ret;}/* Return a malloc()'d copy of a string */char *strdup(str)char *str;{ char *ret; ret=(char *)ck_malloc(strlen(str)+2); strcpy(ret,str); return ret;}/* * memchr - search for a byte * */VOID *memchr(s, ucharwanted, size)VOID *s;int ucharwanted;int size;{ register char *scan; register n; register uc; scan = (char *)s; uc = (ucharwanted&0xFF); for (n = size; n > 0; n--) if ((*scan)&0xFF == uc) return((VOID *)scan); else scan++; return 0;}/* * memmove - copy bytes, being careful about overlap. */VOID *memmove(dst, src, size)VOID *dst;VOID *src;int size;{ register char *d; register char *s; register int n; if (size <= 0) return(dst); s = (char *)src; d = (char *)dst; if (s <= d && s + (size-1) >= d) { /* Overlap, must copy right-to-left. */ s += size-1; d += size-1; for (n = size; n > 0; n--) *d-- = *s--; } else for (n = size; n > 0; n--) *d++ = *s++; return(dst);}/* Implement a variable sized buffer of 'stuff'. We don't know what it is, nor do we care, as long as it doesn't mind being aligned by malloc. */struct buffer { int allocated; int length; char *b;};#define MIN_ALLOCATE 50VOID *init_buffer(){ struct buffer *b; b=(struct buffer *)ck_malloc(sizeof(struct buffer)); b->allocated=MIN_ALLOCATE; b->b=(char *)ck_malloc(MIN_ALLOCATE); b->length=0; return (VOID *)b;}voidflush_buffer(bb)VOID *bb;{ struct buffer *b; b=(struct buffer *)bb; free(b->b); b->b=0; b->allocated=0; b->length=0; free(b);}intsize_buffer(b)VOID *b;{ struct buffer *bb; bb=(struct buffer *)b; return bb->length;}voidadd_buffer(bb,p,n)VOID *bb;char *p;int n;{ struct buffer *b; b=(struct buffer *)bb; if(b->length+n>b->allocated) { b->allocated*=2; b->b=(char *)ck_realloc(b->b,b->allocated); } bcopy(p,b->b+b->length,n); b->length+=n;}voidadd1_buffer(bb,ch)VOID *bb;int ch;{ struct buffer *b; b=(struct buffer *)bb; if(b->length+1>b->allocated) { b->allocated*=2; b->b=(char *)ck_realloc(b->b,b->allocated); } b->b[b->length]=ch; b->length++;}char *get_buffer(bb)VOID *bb;{ struct buffer *b; b=(struct buffer *)bb; return b->b;}#endif :MPW:MPW Tools:Tools with Source:gnu sed ƒ:sed.make
# File: sed.make for macII only version# Target: sed# Sources: sed.c regex.c glob.c# Created: Tuesday, May 22, 1990 10:44:56 AMOBJECTS = sed.c.o regex.c.o glob.c.o alloca.c.o att.getopt.c.oCOptions = -d USG -mc68020 -mc68881 -elems881 sed ƒƒ sed.make {OBJECTS} Link -d -c 'MPS ' -t MPST ∂ {OBJECTS} ∂ "{CLibraries}"Clib881.o ∂ "{CLibraries}"CSANELib881.o ∂ "{CLibraries}"Math881.o ∂ #"{CLibraries}"Complex881.o ∂ "{CLibraries}"StdClib.o ∂ "{CLibraries}"CInterface.o ∂ #"{Libraries}"Stubs.o ∂ "{CLibraries}"CRuntime.o ∂ "{Libraries}"Interface.o ∂ "{Libraries}"ToolLibs.o ∂ -o sed :MPW:MPW Tools:Tools with Source:gnu sed ƒ:sed.man
sed(1) Name sed - stream text editor Syntax sed [-n] [-e script] [-f sfile] [file...] Description The sed command copies the named files (standard input default) to the standard output, edited according to a script of commands. The -f option causes the script to be taken from file sfile; these options accumulate. If there is just one -e option and no -f's, the flag -e may be omitted. The -n option suppresses the default output. A script consists of editing commands, one per line, of the fol- lowing form: [address [, address] ] function [arguments] In normal operation sed cyclically copies a line of input into a pattern space (unless there is something left after a `D' com- mand), applies in sequence all commands whose addresses select that pattern space, and at the end of the script copies the pat- tern space to the standard output (except under -n) and deletes the pattern space. An address is either a decimal number that counts input lines cumulatively across files, a `$' that addresses the last line of input, or a context address, `/regular expression/', in the style of ed(1) modified thus: • In a context address, the construction \?regular expres- sion?, where ? is any character, is identical to /regular expression/. Note that in the context address \xabc\xdefx, the second x stands for itself, so that the regular expression is abcxdef. • The escape sequence `\n' matches a new line embedded in the pattern space. • A command line with no addresses selects every pattern space. • A command line with one address selects each pattern space that matches the address. • A command line with two addresses selects the inclusive range from the first pattern space that matches the first address through the next pattern space that matches the second. (If the second address is a number less than or equal to the line number first selected, only one line is selected.) Thereafter the process is repeated, looking again for the first address. 1 sed(1) Editing commands can be applied only to non-selected pattern spaces by use of the negation function `!' (below). In the following list of functions the maximum number of permis- sible addresses for each function is indicated in parentheses. An argument denoted text consists of one or more lines, all but the last of which end with `\' to hide the new line. Backslashes in text are treated like backslashes in the replacement string of an `s' command, and may be used to protect initial blanks and tabs against the stripping that is done on every script line. An argument denoted rfile or wfile must terminate the command line and must be preceded by exactly one blank. Each wfile is created before processing begins. There can be at most 10 dis- tinct wfile arguments. (1)a\ text Append. Place text on the output before reading the next input line. (2)b label Branch to the `:' command bearing the label. If label is empty, branch to the end of the script. (2)c\ text Change. Delete the pattern space. With 0 or 1 address or at the end of a 2-address range, place text on the output. Start the next cycle. (2)d Delete the pattern space. Start the next cycle. (2)D Delete the initial segment of the pattern space through the first new line. Start the next cycle. (2)g Replace the contents of the pattern space by the contents of the hold space. (2)G Append the contents of the hold space to the pattern space. (2)h Replace the contents of the hold space by the contents of the pattern space. (2)H Append the contents of the pattern space to the hold space. (1)i\ text Insert. Place text on the standard output. 2 sed(1) (2)n Copy the pattern space to the standard output. Replace the pattern space with the next line of input. (2)N Append the next line of input to the pattern space with an embedded new line. (The current line number changes.) (2)p Print. Copy the pattern space to the standard output. (2)P Copy the initial segment of the pattern space through the first new line to the standard output. (1)q Quit. Branch to the end of the script. Do not start a new cycle. (2)r rfile Read the contents of rfile. Place them on the output before reading the next input line. (2)s/regular expression/replacement/flags Substitute the replacement string for instances of the regular expression in the pattern space. Any character may be used instead of `/'. For a more complete descrip- tion see ed(1). The flags is zero or more of g Global. Substitute for all nonoverlapping instances of the regular expression rather than just the first one. p Print the pattern space if a replacement was made. w wfile Write. Append the pattern space to wfile if a replacement was made. (2)t label Test. Branch to the `:' command bearing the label if any substitutions have been made since the most recent read- ing of an input line or execution of a `t'. If label is empty, branch to the end of the script. (2)w wfile Write. Append the pattern space to wfile. (2)x Exchange the contents of the pattern and hold spaces. (2)y/string1/string2/ Transform. Replace all occurrences of characters in string1 with the corresponding character in string2. The lengths of string1 and string2 must be equal. (2)! function Don't. Apply the function (or group, if function is `{') only to lines not selected by the address(es). 3 sed(1) (0): label This command does nothing; it bears a label for `b' and `t' commands to branch to. (1)= Place the current line number on the standard output as a line. (2){ Execute the following commands through a matching `}' only when the pattern space is selected. (0) An empty command is ignored. Options -e script Uses specified file as input file of commands to be exe- cuted. -f sfile Uses specified file as input file of commands to be exe- cuted. May be used with -e option to indicate two script files. -n Suppresses all normal output. See Also awk(1), ed(1), grep(1), lex(1) 4 :MPW:MPW Tools:Tools with Source:gnu sed ƒ:unixMakefile
# Makefile for GNU SED, a batch editor.# Copyright (C) 1987, 1988, 1989 Free Software Foundation, Inc.# # This file is part of GNU SED.# # GNU SED is free software; you can redistribute it and/or modify# it under the terms of the GNU General Public License as published by# the Free Software Foundation; either version 1, or (at your option)# any later version.# # GNU SED is distributed in the hope that it will be useful,# but WITHOUT ANY WARRANTY; without even the implied warranty of# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the# GNU General Public License for more details.# # You should have received a copy of the GNU General Public License# along with GNU SED; see the file COPYING. If not, write to# the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.OBJS = sed.o regex.o glob.oSRC = README sed.c regex.c glob.c regex.h Makefile# on SysV systems, comment out the next line and comment out the one below it#CFLAGS = -g -DUSG -I.CFLAGS = -g -I.# if your machine doesn't have vfprintf() add -DNO_VFPRINTF to the above linessed: $(OBJS) $(CC) $(LINK) -o sed $(OBJS)clean: rm -f sed $(OBJS) core butgs sed.tar.Zdist: sed.tar.Zsed.tar.Z: tar cvhzf sed.tar.Z $(SRC) :MPW:MPW Tools:Tools with Source:gnu sed ƒ:unixREAMDE
This is the 'new, improvevd' GNU sed. Please report all bugs, comments,requests for features, etc to hack@gnu.ai.mit.edu or hack@wheaties.ai.mit.eduor hack@media-lab.media.mit.edu or hack@lsrhs.UUCP (ONE of them should work.)To compile sed, use something on the order ofcc -g -I. -o sed sed.c regex.c glob.cor use the enclosed MakefileIf you don't have vfprintf(), add -DNO_VFPRINTF to the cc command, orto the CFLAGS in the Makefile. :MPW:MPW Tools:Tools with Source:Grep ƒ:alloca.a
;;;; Alloca() for Macintosh Programmer's Workshop C.;; alloca(n) allocates n bytes of storage in the stack;; frame of the caller.;;;; APPLE APPLE APPLE APPLE APPLE APPLE APPLE APPLE APPLE APPLE;; MACINTOSH MACINTOSH MACINTOSH MACINTOSH MACINTOSH MACINTOSH CASE ON alloca PROC EXPORT move.l (sp)+,a0 ; pop return address move.l (sp)+,d0 ; pop parameter = size in bytes add.l #3,d0 ; round size up to long word and.l #-4,d0 ; mask out lower two bits of size sub.l d0,sp ; allocate by moving stack pointer move.l sp,d0 ; return pointer add.l #-4,sp ; new top of stack jmp (a0) ; return to caller ENDP END :MPW:MPW Tools:Tools with Source:Grep ƒ:alloca.c
/* alloca -- (mostly) portable public-domain implementation -- D A Gwyn This implementation of the PWB library alloca() function, which is used to allocate space off the run-time stack so that it is automatically reclaimed upon procedure exit, was inspired by discussions with J. Q. Johnson of Cornell. It should work under any C implementation that uses an actual procedure stack (as opposed to a linked list of frames). There are some preprocessor constants that can be defined when compiling for your specific system, for improved efficiency; however, the defaults should be okay. The general concept of this implementation is to keep track of all alloca()-allocated blocks, and reclaim any that are found to be deeper in the stack than the current invocation. This heuristic does not reclaim storage as soon as it becomes invalid, but it will do so eventually. As a special case, alloca(0) reclaims storage without allocating any. It is a good idea to use alloca(0) in your main control loop, etc. to force garbage collection.*/#ifndef lintstatic char SCCSid[] = "@(#)alloca.c 1.1"; /* for the "what" utility */#endif#ifdef emacs#include "config.h"#ifdef static/* actually, only want this if static is defined as "" -- this is for usg, in which emacs must undefine static in order to make unexec workable */#ifndef STACK_DIRECTIONyoulose-- must know STACK_DIRECTION at compile-time#endif /* STACK_DIRECTION undefined */#endif static#endif emacs#ifdef X3J11typedef void *pointer; /* generic pointer type */#elsetypedef char *pointer; /* generic pointer type */#endif#define NULL 0 /* null pointer constant */extern void free();extern pointer malloc();/* Define STACK_DIRECTION if you know the direction of stack growth for your system; otherwise it will be automatically deduced at run-time. STACK_DIRECTION > 0 => grows toward higher addresses STACK_DIRECTION < 0 => grows toward lower addresses STACK_DIRECTION = 0 => direction of growth unknown*/#ifndef STACK_DIRECTION#define STACK_DIRECTION 0 /* direction unknown */#endif#if STACK_DIRECTION != 0#define STACK_DIR STACK_DIRECTION /* known at compile-time */#else /* STACK_DIRECTION == 0; need run-time code */static int stack_dir; /* 1 or -1 once known */#define STACK_DIR stack_dirstatic voidfind_stack_direction (/* void */){ static char *addr = NULL; /* address of first `dummy', once known */ auto char dummy; /* to get stack address */ if (addr == NULL) { /* initial entry */ addr = &dummy; ck_direction (); /* recurse once */ } else /* second entry */ if (&dummy > addr) stack_dir = 1; /* stack grew upward */ else stack_dir = -1; /* stack grew downward */}#endif /* STACK_DIRECTION == 0 *//* An "alloca header" is used to: (a) chain together all alloca()ed blocks; (b) keep track of stack depth. It is very important that sizeof(header) agree with malloc() alignment chunk size. The following default should work okay.*/#ifndef ALIGN_SIZE#define ALIGN_SIZE sizeof(double)#endiftypedef union hdr{ char align[ALIGN_SIZE]; /* to force sizeof(header) */ struct { union hdr *next; /* for chaining headers */ char *deep; /* for stack depth measure */ } h;} header;/* alloca( size ) returns a pointer to at least `size' bytes of storage which will be automatically reclaimed upon exit from the procedure that called alloca(). Originally, this space was supposed to be taken from the current stack frame of the caller, but that method cannot be made to work for some implementations of C, for example under Gould's UTX/32.*/static header *last_alloca_header = NULL; /* -> last alloca header */pointeralloca (size) /* returns pointer to storage */ unsigned size; /* # bytes to allocate */{ auto char probe; /* probes stack depth: */ register char *depth = &probe;#if STACK_DIRECTION == 0 if (STACK_DIR == 0) /* unknown growth direction */ find_stack_direction ();#endif /* Reclaim garbage, defined as all alloca()ed storage that was allocated from deeper in the stack than currently. */ { register header *hp; /* traverses linked list */ for (hp = last_alloca_header; hp != NULL;) if (STACK_DIR > 0 && hp->h.deep > depth || STACK_DIR < 0 && hp->h.deep < depth) { register header *np = hp->h.next; free ((pointer) hp); /* collect garbage */ hp = np; /* -> next header */ } else break; /* rest are not deeper */ last_alloca_header = hp; /* -> last valid storage */ } if (size == 0) return NULL; /* no allocation required */ /* Allocate combined header + user data storage. */ { register pointer new = malloc (sizeof (header) + size); /* address of header */ ((header *)new)->h.next = last_alloca_header; ((header *)new)->h.deep = depth; last_alloca_header = (header *)new; /* User storage begins just after header. */ return (pointer)((char *)new + sizeof(header)); }} :MPW:MPW Tools:Tools with Source:Grep ƒ:dfa.c
/* dfa.c - determinisitic extended regexp routines for GNU Copyright (C) 1988 Free Software Foundation, Inc. Written June, 1988 by Mike Haertel Modified July, 1988 by Arthur David Olson to assist BMG speedups NO WARRANTY BECAUSE THIS PROGRAM IS LICENSED FREE OF CHARGE, WE PROVIDE ABSOLUTELYNO WARRANTY, TO THE EXTENT PERMITTED BY APPLICABLE STATE LAW. EXCEPTWHEN OTHERWISE STATED IN WRITING, FREE SOFTWARE FOUNDATION, INC,RICHARD M. STALLMAN AND/OR OTHER PARTIES PROVIDE THIS PROGRAM "AS IS"WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING,BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY ANDFITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITYAND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVEDEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR ORCORRECTION. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW WILL RICHARD M.STALLMAN, THE FREE SOFTWARE FOUNDATION, INC., AND/OR ANY OTHER PARTYWHO MAY MODIFY AND REDISTRIBUTE THIS PROGRAM AS PERMITTED BELOW, BELIABLE TO YOU FOR DAMAGES, INCLUDING ANY LOST PROFITS, LOST MONIES, OROTHER SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THEUSE OR INABILITY TO USE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA ORDATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY THIRD PARTIES ORA FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS) THISPROGRAM, EVEN IF YOU HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCHDAMAGES, OR FOR ANY CLAIM BY ANY OTHER PARTY. GENERAL PUBLIC LICENSE TO COPY 1. You may copy and distribute verbatim copies of this source fileas you receive it, in any medium, provided that you conspicuously andappropriately publish on each copy a valid copyright notice "Copyright (C) 1988 Free Software Foundation, Inc."; and include following thecopyright notice a verbatim copy of the above disclaimer of warrantyand of this License. You may charge a distribution fee for thephysical act of transferring a copy. 2. You may modify your copy or copies of this source file orany portion of it, and copy and distribute such modifications underthe terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains or is a derivative of this program or any part thereof, to be licensed at no charge to all third parties on terms identical to those contained in this License Agreement (except that you may choose to grant more extensive warranty protection to some or all third parties, at your option). c) You may charge a distribution fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee.Mere aggregation of another unrelated program with this program (or itsderivative) on a volume of a storage or distribution medium does not bringthe other program under the scope of these terms. 3. You may copy and distribute this program or any portion of it incompiled, executable or object code form under the terms of Paragraphs1 and 2 above provided that you do the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal shipping charge) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.)For an executable file, complete source code means all the source code forall modules it contains; but, as a special exception, it need not includesource code for modules which are standard libraries that accompany theoperating system on which the executable file runs. 4. You may not copy, sublicense, distribute or transfer this programexcept as expressly provided under this License Agreement. Any attemptotherwise to copy, sublicense, distribute or transfer this program is void andyour rights to use the program under this License agreement shall beautomatically terminated. However, parties who have received computersoftware programs from you with this License Agreement will not havetheir licenses terminated so long as such parties remain in full compliance. 5. If you wish to incorporate parts of this program into other freeprograms whose distribution conditions are different, write to the FreeSoftware Foundation at 675 Mass Ave, Cambridge, MA 02139. We have not yetworked out a simple rule that can be stated here, but we will often permitthis. We will be guided by the two goals of preserving the free status ofall derivatives our free software and of promoting the sharing and reuse ofsoftware.In other words, you are welcome to use, share and improve this program.You are forbidden to forbid anyone else to use, share and improvewhat you give them. Help stamp out software-hoarding! */ #include <stdio.h>#include <assert.h>#include <ctype.h>#include "dfa.h"#ifdef __STDC__typedef void *ptr_t;#elsetypedef char *ptr_t;#endifstatic void regmust();static ptr_txcalloc(n, s) int n; size_t s;{ ptr_t r = calloc(n, s); if (r) return r; else regerror("Memory exhausted");}static ptr_txmalloc(n) size_t n;{ ptr_t r = malloc(n); assert(n != 0); if (r) return r; else regerror("Memory exhausted");}static ptr_txrealloc(p, n) ptr_t p; size_t n;{ ptr_t r = realloc(p, n); assert(n != 0); if (r) return r; else regerror("Memory exhausted");}#define CALLOC(p, t, n) ((p) = (t *) xcalloc((n), sizeof (t)))#define MALLOC(p, t, n) ((p) = (t *) xmalloc((n) * sizeof (t)))#define REALLOC(p, t, n) ((p) = (t *) xrealloc((ptr_t) (p), (n) * sizeof (t)))/* Reallocate an array of type t if nalloc is too small for index. */#define REALLOC_IF_NECESSARY(p, t, nalloc, index) \ if ((index) >= (nalloc)) \ { \ while ((index) >= (nalloc)) \ (nalloc) *= 2; \ REALLOC(p, t, nalloc); \ } /* Stuff pertaining to charsets. */statictstbit(b, c) int b; _charset c;{ return c[b / INTBITS] & 1 << b % INTBITS;}static voidsetbit(b, c) int b; _charset c;{ c[b / INTBITS] |= 1 << b % INTBITS;}static voidclrbit(b, c) int b; _charset c;{ c[b / INTBITS] &= ~(1 << b % INTBITS);}static voidcopyset(src, dst) const _charset src; _charset dst;{ int i; for (i = 0; i < _CHARSET_INTS; ++i) dst[i] = src[i];}static voidzeroset(s) _charset s;{ int i; for (i = 0; i < _CHARSET_INTS; ++i) s[i] = 0;}static voidnotset(s) _charset s;{ int i; for (i = 0; i < _CHARSET_INTS; ++i) s[i] = ~s[i];}staticequal(s1, s2) const _charset s1; const _charset s2;{ int i; for (i = 0; i < _CHARSET_INTS; ++i) if (s1[i] != s2[i]) return 0; return 1;} /* A pointer to the current regexp is kept here during parsing. */static struct regexp *reg;/* Find the index of charset s in reg->charsets, or allocate a new charset. */staticcharset_index(s) const _charset s;{ int i; for (i = 0; i < reg->cindex; ++i) if (equal(s, reg->charsets[i])) return i; REALLOC_IF_NECESSARY(reg->charsets, _charset, reg->calloc, reg->cindex); ++reg->cindex; copyset(s, reg->charsets[i]); return i;}/* Syntax bits controlling the behavior of the lexical analyzer. */static syntax_bits, syntax_bits_set;/* Flag for case-folding letters into sets. */static case_fold;/* Entry point to set syntax options. */voidregsyntax(bits, fold) int bits; int fold;{ syntax_bits_set = 1; syntax_bits = bits; case_fold = fold;}/* Lexical analyzer. */static const char *lexstart; /* Pointer to beginning of input string. */static const char *lexptr; /* Pointer to next input character. */static lexleft; /* Number of characters remaining. */static caret_allowed; /* True if backward context allows ^ (meaningful only if RE_CONTEXT_INDEP_OPS is turned off). */static closure_allowed; /* True if backward context allows closures (meaningful only if RE_CONTEXT_INDEP_OPS is turned off). *//* Note that characters become unsigned here. */#define FETCH(c, eoferr) \ { \ if (! lexleft) \ if (eoferr) \ regerror(eoferr); \ else \ return _END; \ (c) = (unsigned char) *lexptr++; \ --lexleft; \ }static _tokenlex(){ _token c, c2; int invert; _charset cset; FETCH(c, (char *) 0); switch (c) { case '^': if (! (syntax_bits & RE_CONTEXT_INDEP_OPS) && (!caret_allowed || (syntax_bits & RE_TIGHT_VBAR) && lexptr - 1 != lexstart)) goto normal_char; caret_allowed = 0; return syntax_bits & RE_TIGHT_VBAR ? _ALLBEGLINE : _BEGLINE; case '$': if (syntax_bits & RE_CONTEXT_INDEP_OPS || !lexleft || (! (syntax_bits & RE_TIGHT_VBAR) && ((syntax_bits & RE_NO_BK_PARENS ? lexleft > 0 && *lexptr == ')' : lexleft > 1 && *lexptr == '\\' && lexptr[1] == ')') || (syntax_bits & RE_NO_BK_VBAR ? lexleft > 0 && *lexptr == '|' : lexleft > 1 && *lexptr == '\\' && lexptr[1] == '|')))) return syntax_bits & RE_TIGHT_VBAR ? _ALLENDLINE : _ENDLINE; goto normal_char; case '\\': FETCH(c, "Unfinished \\ quote"); switch (c) { case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': caret_allowed = 0; closure_allowed = 1; return _BACKREF; case '<': caret_allowed = 0; return _BEGWORD; case '>': caret_allowed = 0; return _ENDWORD; case 'b': caret_allowed = 0; return _LIMWORD; case 'B': caret_allowed = 0; return _NOTLIMWORD; case 'w': case 'W': zeroset(cset); for (c2 = 0; c2 < _NOTCHAR; ++c2) if (ISALNUM(c2)) setbit(c2, cset); if (c == 'W') notset(cset); caret_allowed = 0; closure_allowed = 1; return _SET + charset_index(cset); case '?': if (syntax_bits & RE_BK_PLUS_QM) goto qmark; goto normal_char; case '+': if (syntax_bits & RE_BK_PLUS_QM) goto plus; goto normal_char; case '|': if (! (syntax_bits & RE_NO_BK_VBAR)) goto or; goto normal_char; case '(': if (! (syntax_bits & RE_NO_BK_PARENS)) goto lparen; goto normal_char; case ')': if (! (syntax_bits & RE_NO_BK_PARENS)) goto rparen; goto normal_char; default: goto normal_char; } case '?': if (syntax_bits & RE_BK_PLUS_QM) goto normal_char; qmark: if (! (syntax_bits & RE_CONTEXT_INDEP_OPS) && !closure_allowed) goto normal_char; return _QMARK; case '*': if (! (syntax_bits & RE_CONTEXT_INDEP_OPS) && !closure_allowed) goto normal_char; return _STAR; case '+': if (syntax_bits & RE_BK_PLUS_QM) goto normal_char; plus: if (! (syntax_bits & RE_CONTEXT_INDEP_OPS) && !closure_allowed) goto normal_char; return _PLUS; case '|': if (! (syntax_bits & RE_NO_BK_VBAR)) goto normal_char; or: caret_allowed = 1; closure_allowed = 0; return _OR; case '\n': if (! (syntax_bits & RE_NEWLINE_OR)) goto normal_char; goto or; case '(': if (! (syntax_bits & RE_NO_BK_PARENS)) goto normal_char; lparen: caret_allowed = 1; closure_allowed = 0; return _LPAREN; case ')': if (! (syntax_bits & RE_NO_BK_PARENS)) goto normal_char; rparen: caret_allowed = 0; closure_allowed = 1; return _RPAREN; case '.': zeroset(cset); notset(cset); clrbit('\n', cset); caret_allowed = 0; closure_allowed = 1; return _SET + charset_index(cset); case '[': zeroset(cset); FETCH(c, "Unbalanced ["); if (c == '^') { FETCH(c, "Unbalanced ["); invert = 1; } else invert = 0; do { FETCH(c2, "Unbalanced ["); if (c2 == '-') { FETCH(c2, "Unbalanced ["); while (c <= c2) setbit(c++, cset); FETCH(c, "Unbalanced ["); } else { setbit(c, cset); c = c2; } } while (c != ']'); if (invert) notset(cset); caret_allowed = 0; closure_allowed = 1; return _SET + charset_index(cset); default: normal_char: caret_allowed = 0; closure_allowed = 1; if (case_fold && ISALPHA(c)) { zeroset(cset); if (isupper(c)) c = tolower(c); setbit(c, cset); setbit(toupper(c), cset); return _SET + charset_index(cset); } return c; }} /* Recursive descent parser for regular expressions. */static _token tok; /* Lookahead token. */static depth; /* Current depth of a hypothetical stack holding deferred productions. This is used to determine the depth that will be required of the real stack later on in reganalyze(). *//* Add the given token to the parse tree, maintaining the depth count and updating the maximum depth if necessary. */static voidaddtok(t) _token t;{ REALLOC_IF_NECESSARY(reg->tokens, _token, reg->talloc, reg->tindex); reg->tokens[reg->tindex++] = t; switch (t) { case _QMARK: case _STAR: case _PLUS: break; case _CAT: case _OR: --depth; break; default: ++reg->nleaves; case _EMPTY: ++depth; break; } if (depth > reg->depth) reg->depth = depth;}/* The grammar understood by the parser is as follows. start: regexp _ALLBEGLINE regexp regexp _ALLENDLINE _ALLBEGLINE regexp _ALLENDLINE regexp: regexp _OR branch branch branch: branch closure closure closure: closure _QMARK closure _STAR closure _PLUS atom atom: <normal character> _SET _BACKREF _BEGLINE _ENDLINE _BEGWORD _ENDWORD _LIMWORD _NOTLIMWORD <empty> The parser builds a parse tree in postfix form in an array of tokens. */#ifdef __STDC__static void regexp(void);#elsestatic void regexp();#endifstatic voidatom(){ if (tok >= 0 && tok < _NOTCHAR || tok >= _SET || tok == _BACKREF || tok == _BEGLINE || tok == _ENDLINE || tok == _BEGWORD || tok == _ENDWORD || tok == _LIMWORD || tok == _NOTLIMWORD) { addtok(tok); tok = lex(); } else if (tok == _LPAREN) { tok = lex(); regexp(); if (tok != _RPAREN) regerror("Unbalanced ("); tok = lex(); } else addtok(_EMPTY);}static voidclosure(){ atom(); while (tok == _QMARK || tok == _STAR || tok == _PLUS) { addtok(tok); tok = lex(); }}static voidbranch(){ closure(); while (tok != _RPAREN && tok != _OR && tok != _ALLENDLINE && tok >= 0) { closure(); addtok(_CAT); }}static voidregexp(){ branch(); while (tok == _OR) { tok = lex(); branch(); addtok(_OR); }}/* Main entry point for the parser. S is a string to be parsed, len is the length of the string, so s can include NUL characters. R is a pointer to the struct regexp to parse into. */voidregparse(s, len, r) const char *s; size_t len; struct regexp
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:Grep ƒ:dfa.c
+++++ Continued from previous card +++++
*r;{ reg = r; lexstart = lexptr = s; lexleft = len; caret_allowed = 1; closure_allowed = 0; if (! syntax_bits_set) regerror("No syntax specified"); tok = lex(); depth = r->depth; if (tok == _ALLBEGLINE) { addtok(_BEGLINE); tok = lex(); regexp(); addtok(_CAT); } else regexp(); if (tok == _ALLENDLINE) { addtok(_ENDLINE); addtok(_CAT); tok = lex(); } if (tok != _END) regerror("Unbalanced )"); addtok(_END - r->nregexps); addtok(_CAT); if (r->nregexps) addtok(_OR); ++r->nregexps;} /* Some primitives for operating on sets of positions. *//* Copy one set to another; the destination must be large enough. */static voidcopy(src, dst) const _position_set *src; _position_set *dst;{ int i; for (i = 0; i < src->nelem; ++i) dst->elems[i] = src->elems[i]; dst->nelem = src->nelem;}/* Insert a position in a set. Position sets are maintained in sorted order according to index. If position already exists in the set with the same index then their constraints are logically or'd together. S->elems must point to an array large enough to hold the resulting set. */static voidinsert(p, s) _position p; _position_set *s;{ int i; _position t1, t2; for (i = 0; i < s->nelem && p.index < s->elems[i].index; ++i) ; if (i < s->nelem && p.index == s->elems[i].index) s->elems[i].constraint |= p.constraint; else { t1 = p; ++s->nelem; while (i < s->nelem) { t2 = s->elems[i]; s->elems[i++] = t1; t1 = t2; } }}/* Merge two sets of positions into a third. The result is exactly as if the positions of both sets were inserted into an initially empty set. */static voidmerge(s1, s2, m) _position_set *s1; _position_set *s2; _position_set *m;{ int i = 0, j = 0; m->nelem = 0; while (i < s1->nelem && j < s2->nelem) if (s1->elems[i].index > s2->elems[j].index) m->elems[m->nelem++] = s1->elems[i++]; else if (s1->elems[i].index < s2->elems[j].index) m->elems[m->nelem++] = s2->elems[j++]; else { m->elems[m->nelem] = s1->elems[i++]; m->elems[m->nelem++].constraint |= s2->elems[j++].constraint; } while (i < s1->nelem) m->elems[m->nelem++] = s1->elems[i++]; while (j < s2->nelem) m->elems[m->nelem++] = s2->elems[j++];}/* Delete a position from a set. */static voiddelete(p, s) _position p; _position_set *s;{ int i; for (i = 0; i < s->nelem; ++i) if (p.index == s->elems[i].index) break; if (i < s->nelem) for (--s->nelem; i < s->nelem; ++i) s->elems[i] = s->elems[i + 1];} /* Find the index of the state corresponding to the given position set with the given preceding context, or create a new state if there is no such state. Newline and letter tell whether we got here on a newline or letter, respectively. */staticstate_index(r, s, newline, letter) struct regexp *r; _position_set *s; int newline; int letter;{ int hash = 0; int constraint; int i, j; newline = newline ? 1 : 0; letter = letter ? 1 : 0; for (i = 0; i < s->nelem; ++i) hash ^= s->elems[i].index + s->elems[i].constraint; /* Try to find a state that exactly matches the proposed one. */ for (i = 0; i < r->sindex; ++i) { if (hash != r->states[i].hash || s->nelem != r->states[i].elems.nelem || newline != r->states[i].newline || letter != r->states[i].letter) continue; for (j = 0; j < s->nelem; ++j) if (s->elems[j].constraint != r->states[i].elems.elems[j].constraint || s->elems[j].index != r->states[i].elems.elems[j].index) break; if (j == s->nelem) return i; } /* We'll have to create a new state. */ REALLOC_IF_NECESSARY(r->states, _dfa_state, r->salloc, r->sindex); r->states[i].hash = hash; MALLOC(r->states[i].elems.elems, _position, s->nelem); copy(s, &r->states[i].elems); r->states[i].newline = newline; r->states[i].letter = letter; r->states[i].backref = 0; r->states[i].constraint = 0; r->states[i].first_end = 0; for (j = 0; j < s->nelem; ++j) if (r->tokens[s->elems[j].index] < 0) { constraint = s->elems[j].constraint; if (_SUCCEEDS_IN_CONTEXT(constraint, newline, 0, letter, 0) || _SUCCEEDS_IN_CONTEXT(constraint, newline, 0, letter, 1) || _SUCCEEDS_IN_CONTEXT(constraint, newline, 1, letter, 0) || _SUCCEEDS_IN_CONTEXT(constraint, newline, 1, letter, 1)) r->states[i].constraint |= constraint; if (! r->states[i].first_end) r->states[i].first_end = r->tokens[s->elems[j].index]; } else if (r->tokens[s->elems[j].index] == _BACKREF) { r->states[i].constraint = _NO_CONSTRAINT; r->states[i].backref = 1; } ++r->sindex; return i;} /* Find the epsilon closure of a set of positions. If any position of the set contains a symbol that matches the empty string in some context, replace that position with the elements of its follow labeled with an appropriate constraint. Repeat exhaustively until no funny positions are left. S->elems must be large enough to hold the result. */epsclosure(s, r) _position_set *s; struct regexp *r;{ int i, j; int *visited; _position p, old; MALLOC(visited, int, r->tindex); for (i = 0; i < r->tindex; ++i) visited[i] = 0; for (i = 0; i < s->nelem; ++i) if (r->tokens[s->elems[i].index] >= _NOTCHAR && r->tokens[s->elems[i].index] != _BACKREF && r->tokens[s->elems[i].index] < _SET) { old = s->elems[i]; p.constraint = old.constraint; delete(s->elems[i], s); if (visited[old.index]) { --i; continue; } visited[old.index] = 1; switch (r->tokens[old.index]) { case _BEGLINE: p.constraint &= _BEGLINE_CONSTRAINT; break; case _ENDLINE: p.constraint &= _ENDLINE_CONSTRAINT; break; case _BEGWORD: p.constraint &= _BEGWORD_CONSTRAINT; break; case _ENDWORD: p.constraint &= _ENDWORD_CONSTRAINT; break; case _LIMWORD: p.constraint &= _ENDWORD_CONSTRAINT; break; case _NOTLIMWORD: p.constraint &= _NOTLIMWORD_CONSTRAINT; break; } for (j = 0; j < r->follows[old.index].nelem; ++j) { p.index = r->follows[old.index].elems[j].index; insert(p, s); } /* Force rescan to start at the beginning. */ i = -1; } free(visited);} /* Perform bottom-up analysis on the parse tree, computing various functions. Note that at this point, we're pretending constructs like \< are real characters rather than constraints on what can follow them. Nullable: A node is nullable if it is at the root of a regexp that can match the empty string. * _EMPTY leaves are nullable. * No other leaf is nullable. * A _QMARK or _STAR node is nullable. * A _PLUS node is nullable if its argument is nullable. * A _CAT node is nullable if both its arguments are nullable. * An _OR node is nullable if either argument is nullable. Firstpos: The firstpos of a node is the set of positions (nonempty leaves) that could correspond to the first character of a string matching the regexp rooted at the given node. * _EMPTY leaves have empty firstpos. * The firstpos of a nonempty leaf is that leaf itself. * The firstpos of a _QMARK, _STAR, or _PLUS node is the firstpos of its argument. * The firstpos of a _CAT node is the firstpos of the left argument, union the firstpos of the right if the left argument is nullable. * The firstpos of an _OR node is the union of firstpos of each argument. Lastpos: The lastpos of a node is the set of positions that could correspond to the last character of a string matching the regexp at the given node. * _EMPTY leaves have empty lastpos. * The lastpos of a nonempty leaf is that leaf itself. * The lastpos of a _QMARK, _STAR, or _PLUS node is the lastpos of its argument. * The lastpos of a _CAT node is the lastpos of its right argument, union the lastpos of the left if the right argument is nullable. * The lastpos of an _OR node is the union of the lastpos of each argument. Follow: The follow of a position is the set of positions that could correspond to the character following a character matching the node in a string matching the regexp. At this point we consider special symbols that match the empty string in some context to be just normal characters. Later, if we find that a special symbol is in a follow set, we will replace it with the elements of its follow, labeled with an appropriate constraint. * Every node in the firstpos of the argument of a _STAR or _PLUS node is in the follow of every node in the lastpos. * Every node in the firstpos of the second argument of a _CAT node is in the follow of every node in the lastpos of the first argument. Because of the postfix representation of the parse tree, the depth-first analysis is conveniently done by a linear scan with the aid of a stack. Sets are stored as arrays of the elements, obeying a stack-like allocation scheme; the number of elements in each set deeper in the stack can be used to determine the address of a particular set's array. */voidreganalyze(r, searchflag) struct regexp *r; int searchflag;{ int *nullable; /* Nullable stack. */ int *nfirstpos; /* Element count stack for firstpos sets. */ _position *firstpos; /* Array where firstpos elements are stored. */ int *nlastpos; /* Element count stack for lastpos sets. */ _position *lastpos; /* Array where lastpos elements are stored. */ int *nalloc; /* Sizes of arrays allocated to follow sets. */ _position_set tmp; /* Temporary set for merging sets. */ _position_set merged; /* Result of merging sets. */ int wants_newline; /* True if some position wants newline info. */ int *o_nullable; int *o_nfirst, *o_nlast; _position *o_firstpos, *o_lastpos; int i, j; _position *pos; r->searchflag = searchflag; MALLOC(nullable, int, r->depth); o_nullable = nullable; MALLOC(nfirstpos, int, r->depth); o_nfirst = nfirstpos; MALLOC(firstpos, _position, r->nleaves); o_firstpos = firstpos, firstpos += r->nleaves; MALLOC(nlastpos, int, r->depth); o_nlast = nlastpos; MALLOC(lastpos, _position, r->nleaves); o_lastpos = lastpos, lastpos += r->nleaves; MALLOC(nalloc, int, r->tindex); for (i = 0; i < r->tindex; ++i) nalloc[i] = 0; MALLOC(merged.elems, _position, r->nleaves); CALLOC(r->follows, _position_set, r->tindex); for (i = 0; i < r->tindex; ++i) switch (r->tokens[i]) { case _EMPTY: /* The empty set is nullable. */ *nullable++ = 1; /* The firstpos and lastpos of the empty leaf are both empty. */ *nfirstpos++ = *nlastpos++ = 0; break; case _STAR: case _PLEvery element in the firstpos of the argument is in the follow of every element in the lastpos. */ tmp.nelem = nfirstpos[-1]; tmp.elems = firstpos; pos = lastpos; for (j = 0; j < nlastpos[-1]; ++j) { merge(&tmp, &r->follows[pos[j].index], &merged); REALLOC_IF_NECESSARY(r->follows[pos[j].index].elems, _position, nalloc[pos[j].index], merged.nelem - 1); copy(&merged, &r->follows[pos[j].index]); } case _QMARK: /* A _QMARK or _STAR node is automatically nullable. */ if (r->tokens[i] != _PLUS) nullable[-1] = 1; break; case _CAT: /* Every element in the firstpos of the second argument is in the follow of every element in the lastpos of the first argument. */ tmp.nelem = nfirstpos[-1]; tmp.elems = firstpos; pos = lastpos + nlastpos[-1]; for (j = 0; j < nlastpos[-2]; ++j) { merge(&tmp, &r->follows[pos[j].index], &merged); REALLOC_IF_NECESSARY(r->follows[pos[j].index].elems, _position, nalloc[pos[j].index], merged.nelem - 1); copy(&merged, &r->follows[pos[j].index]); } /* The firstpos of a _CAT node is the firstpos of the first argument, union that of the second argument if the first is nullable. */ if (nullable[-2]) nfirstpos[-2] += nfirstpos[-1]; else firstpos += nfirstpos[-1]; --nfirstpos; /* The lastpos of a _CAT node is the lastpos of the second argument, union that of the first argument if the second is nullable. */ if (nullable[-1]) nlastpos[-2] += nlastpos[-1]; else { pos = lastpos + nlastpos[-2]; for (j = nlastpos[-1] - 1; j >= 0; --j) pos[j] = lastpos[j]; lastpos += nlastpos[-2]; nlastpos[-2] = nlastpos[-1]; } --nlastpos; /* A _CAT node is nullable if both arguments are nullable. */ nullable[-2] = nullable[-1] && nullable[-2]; --nullable; break; case _OR: /* The firstpos is the union of the firstpos of each argument. */ nfirstpos[-2] += nfirstpos[-1]; --nfirstpos; /* The lastpos is the union of the lastpos of each argument. */ nlastpos[-2] += nlastpos[-1]; --nlastpos; /* An _OR node is nullable if either argument is nullable. */ nullable[-2] = nullable[-1] || nullable[-2]; --nullable; break; default: /* Anything else is a nonempty position. (Note that special constructs like \< are treated as nonempty strings here; an "epsilon closure" effectively makes them nullable later. Backreferences have to get a real position so we can detect transitions on them later. But they are nullable. */ *nullable++ = r->tokens[i] == _BACKREF; /* This position is in its own firstpos and lastpos. */ *nfirstpos++ = *nlastpos++ = 1; --firstpos, --lastpos; firstpos->index = lastpos->index = i; firstpos->constraint = lastpos->constraint = _NO_CONSTRAINT; /* Allocate the follow set for this position. */ nalloc[i] = 1; MALLOC(r->follows[i].elems, _position, nalloc[i]); break; } /* For each follow set that is the follow set of a real position, replace it with its epsilon closure. */ for (i = 0; i < r->tindex; ++i) if (r->tokens[i] < _NOTCHAR || r->tokens[i] == _BACKREF || r->tokens[i] >= _SET) { copy(&r->follows[i], &merged); epsclosure(&merged, r); if (r->follows[i].nelem < merged.nelem) REALLOC(r->follows[i].elems, _position, merged.nelem); copy(&merged, &r->follows[i]); } /* Get the epsilon closure of the firstpos of the regexp. The result will be the set of positions of state 0. */ merged.nelem = 0; for (i = 0; i < nfirstpos[-1]; ++i) insert(firstpos[i], &merged); epsclosure(&merged, r); /* Check if any of the positions of state 0 will want newline context. */ wants_newline = 0; for (i = 0; i < merged.nelem; ++i) if (_PREV_NEWLINE_DEPENDENT(merged.elems[i].constraint)) wants_newline = 1; /* Build the initial state. */ r->salloc = 1; r->sindex = 0; MALLOC(r->states, _dfa_state, r->salloc); state_index(r, &merged, wants_newline, 0); free(o_nullable); free(o_nfirst); free(o_firstpos); free(o_nlast); free(o_lastpos); free(nalloc); free(merged.elems);} /* Find, for each character, the transition out of state s of r, and store it in the appropriate slot of trans. We divide the positions of s into groups (positions can appear in more than one group). Each group is labeled with a set of characters that every position in the group matches (taking into account, if necessary, preceding context information of s). For each group, find the union of the its elements' follows. This set is the set of positions of the new state. For each character in the group's label, set the transition on this character to be to a state corresponding to the set's positions, and its associated backward context information, if necessary. If we are building a searching matcher, we include the positions of state 0 in every state. The collection of groups is constructed by building an equivalence-class partitio
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:Grep ƒ:dfa.c
+++++ Continued from previous card +++++
n of the positions of s. For each position, find the set of characters C that it matches. Eliminate any characters from C that fail on grounds of backward context. Search through the groups, looking for a group whose label L has nonempty intersection with C. If L - C is nonempty, create a new group labeled L - C and having the same positions as the current group, and set L to the intersection of L and C. Insert the position in this group, set C = C - L, and resume scanning. If after comparing with every group there are characters remaining in C, create a new group labeled with the characters of C and insert this position in that group. */voidregstate(s, r, trans) int s; struct regexp *r; int trans[];{ _position_set grps[_NOTCHAR]; /* As many as will ever be needed. */ _charset labels[_NOTCHAR]; /* Labels corresponding to the groups. */ int ngrps = 0; /* Number of groups actually used. */ _position pos; /* Current position being considered. */ _charset matches; /* Set of matching characters. */ int matchesf; /* True if matches is nonempty. */ _charset intersect; /* Intersection with some label set. */ int intersectf; /* True if intersect is nonempty. */ _charset leftovers; /* Stuff in the label that didn't match. */ int leftoversf; /* True if leftovers is nonempty. */ static _charset letters; /* Set of characters considered letters. */ static _charset newline; /* Set of characters that aren't newline. */ _position_set follows; /* Union of the follows of some group. */ _position_set tmp; /* Temporary space for merging sets. */ int state; /* New state. */ int wants_newline; /* New state wants to know newline context. */ int state_newline; /* New state on a newline transition. */ int wants_letter; /* New state wants to know letter context. */ int state_letter; /* New state on a letter transition. */ static initialized; /* Flag for static initialization. */ int i, j, k; /* Initialize the set of letters, if necessary. */ if (! initialized) { initialized = 1; for (i = 0; i < _NOTCHAR; ++i) if (ISALNUM(i)) setbit(i, letters); setbit('\n', newline); } zeroset(matches); for (i = 0; i < r->states[s].elems.nelem; ++i) { pos = r->states[s].elems.elems[i]; if (r->tokens[pos.index] >= 0 && r->tokens[pos.index] < _NOTCHAR) setbit(r->tokens[pos.index], matches); else if (r->tokens[pos.index] >= _SET) copyset(r->charsets[r->tokens[pos.index] - _SET], matches); else continue; /* Some characters may need to be climinated from matches because they fail in the current context. */ if (pos.constraint != 0xff) { if (! _MATCHES_NEWLINE_CONTEXT(pos.constraint, r->states[s].newline, 1)) clrbit('\n', matches); if (! _MATCHES_NEWLINE_CONTEXT(pos.constraint, r->states[s].newline, 0)) for (j = 0; j < _CHARSET_INTS; ++j) matches[j] &= newline[j]; if (! _MATCHES_LETTER_CONTEXT(pos.constraint, r->states[s].letter, 1)) for (j = 0; j < _CHARSET_INTS; ++j) matches[j] &= ~letters[j]; if (! _MATCHES_LETTER_CONTEXT(pos.constraint, r->states[s].letter, 0)) for (j = 0; j < _CHARSET_INTS; ++j) matches[j] &= letters[j]; /* If there are no characters left, there's no point in going on. */ for (j = 0; j < _CHARSET_INTS && !matches[j]; ++j) ; if (j == _CHARSET_INTS) continue; } for (j = 0; j < ngrps; ++j) { /* If matches contains a single character only, and the current group's label doesn't contain that character, go on to the next group. */ if (r->tokens[pos.index] >= 0 && r->tokens[pos.index] < _NOTCHAR && !tstbit(r->tokens[pos.index], labels[j])) continue; /* Check if this group's label has a nonempty intersection with matches. */ intersectf = 0; for (k = 0; k < _CHARSET_INTS; ++k) (intersect[k] = matches[k] & labels[j][k]) ? intersectf = 1 : 0; if (! intersectf) continue; /* It does; now find the set differences both ways. */ leftoversf = matchesf = 0; for (k = 0; k < _CHARSET_INTS; ++k) { /* Even an optimizing compiler can't know this for sure. */ int match = matches[k], label = labels[j][k]; (leftovers[k] = ~match & label) ? leftoversf = 1 : 0; (matches[k] = match & ~label) ? matchesf = 1 : 0; } /* If there were leftovers, create a new group labeled with them. */ if (leftoversf) { copyset(leftovers, labels[ngrps]); copyset(intersect, labels[j]); MALLOC(grps[ngrps].elems, _position, r->nleaves); copy(&grps[j], &grps[ngrps]); ++ngrps; } /* Put the position in the current group. Note that there is no reason to call insert() here. */ grps[j].elems[grps[j].nelem++] = pos; /* If every character matching the current position has been accounted for, we're done. */ if (! matchesf) break; } /* If we've passed the last group, and there are still characters unaccounted for, then we'll have to create a new group. */ if (j == ngrps) { copyset(matches, labels[ngrps]); zeroset(matches); MALLOC(grps[ngrps].elems, _position, r->nleaves); grps[ngrps].nelem = 1; grps[ngrps].elems[0] = pos; ++ngrps; } } MALLOC(follows.elems, _position, r->nleaves); MALLOC(tmp.elems, _position, r->nleaves); /* If we are a searching matcher, the default transition is to a state containing the positions of state 0, otherwise the default transition is to fail miserably. */ if (r->searchflag) { wants_newline = 0; wants_letter = 0; for (i = 0; i < r->states[0].elems.nelem; ++i) { if (_PREV_NEWLINE_DEPENDENT(r->states[0].elems.elems[i].constraint)) wants_newline = 1; if (_PREV_LETTER_DEPENDENT(r->states[0].elems.elems[i].constraint)) wants_letter = 1; } copy(&r->states[0].elems, &follows); state = state_index(r, &follows, 0, 0); if (wants_newline) state_newline = state_index(r, &follows, 1, 0); else state_newline = state; if (wants_letter) state_letter = state_index(r, &follows, 0, 1); else state_letter = state; for (i = 0; i < _NOTCHAR; ++i) if (i == '\n') trans[i] = state_newline; else if (ISALNUM(i)) trans[i] = state_letter; else trans[i] = state; } else for (i = 0; i < _NOTCHAR; ++i) trans[i] = -1; for (i = 0; i < ngrps; ++i) { follows.nelem = 0; /* Find the union of the follows of the positions of the group. This is a hideously inefficient loop. Fix it someday. */ for (j = 0; j < grps[i].nelem; ++j) for (k = 0; k < r->follows[grps[i].elems[j].index].nelem; ++k) insert(r->follows[grps[i].elems[j].index].elems[k], &follows); /* If we are building a searching matche in the positions of state 0 as well. */ if (r->searchflag) for (j = 0; j < r->states[0].elems.nelem; ++j) insert(r->states[0].elems.elems[j], &follows); /* Find out if the new state will want any context information. */ wants_newline = 0; if (tstbit('\n', labels[i])) for (j = 0; j < follows.nelem; ++j) if (_PREV_NEWLINE_DEPENDENT(follows.elems[j].constraint)) wants_newline = 1; wants_letter = 0; for (j = 0; j < _CHARSET_INTS; ++j) if (labels[i][j] & letters[j]) break; if (j < _CHARSET_INTS) for (j = 0; j < follows.nelem; ++j) if (_PREV_LETTER_DEPENDENT(follows.elems[j].constraint)) wants_letter = 1; /* Find the state(s) corresponding to the union of the follows. */ state = state_index(r, &follows, 0, 0); if (wants_newline) state_newline = state_index(r, &follows, 1, 0); else state_newline = state; if (wants_letter) state_letter = state_index(r, &follows, 0, 1); else state_letter = state; /* Set the transitions for each character in the current label. */ for (j = 0; j < _CHARSET_INTS; ++j) for (k = 0; k < INTBITS; ++k) if (labels[i][j] & 1 << k) { int c = j * INTBITS + k; if (c == '\n') trans[c] = state_newline; else if (ISALNUM(c)) trans[c] = state_letter; else if (c < _NOTCHAR) trans[c] = state; } } for (i = 0; i < ngrps; ++i) free(grps[i].elems); free(follows.elems); free(tmp.elems);} /* Some routines for manipulating a compiled regexp's transition tables. Each state may or may not have a transition table; if it does, and it is a non-accepting state, then r->trans[state] points to its table. If it is an accepting state then r->fails[state] points to its table. If it has no table at all, then r->trans[state] is NULL. TODO: Improve this comment, get rid of the unnecessary redundancy. */static voidbuild_state(s, r) int s; struct regexp *r;{ int *trans; /* The new transition table. */ int i; /* Set an upper limit on the number of transition tables that will ever exist at once. 1024 is arbitrary. The idea is that the frequently used transition tables will be quickly rebuilt, whereas the ones that were only needed once or twice will be cleared away. */ if (r->trcount >= 1024) { for (i = 0; i < r->tralloc; ++i) if (r->trans[i]) { free((ptr_t) r->trans[i]); r->trans[i] = NULL; } else if (r->fails[i]) { free((ptr_t) r->fails[i]); r->fails[i] = NULL; } r->trcount = 0; } ++r->trcount; /* Set up the success bits for this state. */ r->success[s] = 0; if (ACCEPTS_IN_CONTEXT(r->states[s].newline, 1, r->states[s].letter, 0, s, *r)) r->success[s] |= 4; if (ACCEPTS_IN_CONTEXT(r->states[s].newline, 0, r->states[s].letter, 1, s, *r)) r->success[s] |= 2; if (ACCEPTS_IN_CONTEXT(r->states[s].newline, 0, r->states[s].letter, 0, s, *r)) r->success[s] |= 1; MALLOC(trans, int, _NOTCHAR); regstate(s, r, trans); /* Now go through the new transition table, and make sure that the trans and fail arrays are allocated large enough to hold a pointer for the largest state mentioned in the table. */ for (i = 0; i < _NOTCHAR; ++i) if (trans[i] >= r->tralloc) { int oldalloc = r->tralloc; while (trans[i] >= r->tralloc) r->tralloc *= 2; REALLOC(r->realtrans, int *, r->tralloc + 1); r->trans = r->realtrans + 1; REALLOC(r->fails, int *, r->tralloc); REALLOC(r->success, int, r->tralloc); REALLOC(r->newlines, int, r->tralloc); while (oldalloc < r->tralloc) { r->trans[oldalloc] = NULL; r->fails[oldalloc++] = NULL; } } /* Keep the newline transition in a special place so we can use it as a sentinel. */ r->newlines[s] = trans['\n']; trans['\n'] = -1; if (ACCEPTING(s, *r)) r->fails[s] = trans; else r->trans[s] = trans;}static voidbuild_state_zero(r) struct regexp *r;{ r->tralloc = 1; r->trcount = 0; CALLOC(r->realtrans, int *, r->tralloc + 1); r->trans = r->realtrans + 1; CALLOC(r->fails, int *, r->tralloc); MALLOC(r->success, int, r->tralloc); MALLOC(r->newlines, int, r->tralloc); build_state(0, r);} /* Search through a buffer looking for a match to the given struct regexp. Find the first occurrence of a string matching the regexp in the buffer, and the shortest possible version thereof. Return a pointer to the first character after the match, or NULL if none is found. Begin points to the beginning of the buffer, and end points to the first character after its end. We store a newline in *end to act as a sentinel, so end had better point somewhere valid. Newline is a flag indicating whether to allow newlines to be in the matching string. If count is non- NULL it points to a place we're supposed to increment every time we see a newline. Finally, if backref is non-NULL it points to a place where we're supposed to store a 1 if backreferencing happened and the match needs to be verified by a backtracking matcher. Otherwise we store a 0 in *backref. */char *regexecute(r, begin, end, newline, count, backref) struct regexp *r; char *begin; char *end; int newline; int *count; int *backref;{ register s, s1, tmp; /* Current state. */ register unsigned char *p; /* Current input character. */ register **trans, *t; /* Copy of r->trans so it can be optimized into a register. */ static sbit[_NOTCHAR]; /* Table for anding with r->success. */ static sbit_init; if (! sbit_init) { int i; sbit_init = 1; for (i = 0; i < _NOTCHAR; ++i) if (i == '\n') sbit[i] = 4; else if (ISALNUM(i)) sbit[i] = 2; else sbit[i] = 1; } if (! r->tralloc) build_state_zero(r); s = 0; p = (unsigned char *) begin; trans = r->trans; *end = '\n'; for (;;) { /* The dreaded inner loop. */ if (t = trans[s]) do { s1 = t[*p++]; if (! (t = trans[s1])) goto last_was_s; s = t[*p++]; } while (t = trans[s]); goto last_was_s1; last_was_s: tmp = s, s = s1, s1 = tmp; last_was_s1: if (s >= 0 && p <= (unsigned char *) end && r->fails[s]) { if (r->success[s] & sbit[*p]) { if (backref) if (r->states[s].backref) *backref = 1; else *backref = 0; return (char *) p; } s1 = s; s = r->fails[s][*p++]; continue; } /* If the previous character was a newline, count it. */ if (count && (char *) p <= end && p[-1] == '\n') ++*count; /* Check if we've run off the end of the buffer. */ if ((char *) p >= end) return NULL; if (s >= 0) { build_state(s, r); trans = r->trans; continue; } if (p[-1] == '\n' && newline) { s = r->newlines[s1]; continue; } s = 0; }} /* Initialize the components of a regexp that the other routines don't initialize for themselves. */voidreginit(r) struct regexp *r;{ r->calloc = 1; MALLOC(r->charsets, _charset, r->calloc); r->cindex = 0; r->talloc = 1; MALLOC(r->tokens, _token, r->talloc); r->tindex = r->depth = r->nleaves = r->nregexps = 0; r->searchflag = 0; r->tralloc = 0;}/* Parse and analyze a single string of the given length. */voidregcompile(s, len, r, searchflag) const char *s; size_t len; struct regexp *r; int searchflag;{ if (case_fold) /* dummy folding in service of regmust() */ { static char *p; case_fold = 0; for (p = (char *)s; *p != 0; p++) if (isupper((int)*p)) *p = tolower((int) *p); reginit(r); r->mustn = 0; r->must[0] = '\0'; regparse(s, len, r); regmust(r); reganalyze(r, searchflag); case_fold = 1; reginit(r); regparse(s, len, r); reganalyze(r, searchflag); } else { reginit(r); regparse(s, len, r); regmust(r); reganalyze(r, searchflag); }}/* Free the storage held by the components of a regexp. */voidregfree(r) struct regexp *r;{ int i; free((ptr_t) r->charsets); free((ptr_t) r->tokens); for (i = 0; i < r->sindex; ++i) free((ptr_t) r->states[i].elems.elems); free((ptr_t) r->states); for (i = 0; i < r->tindex; ++i) if (r->follows[i].elems) free((ptr_t) r->follows[i].elems); free((ptr_t) r->follows); for (i = 0; i < r->tralloc; ++i) if (r->trans[i]) free((ptr_t) r->trans[i]); else if (r->fails[i]) free((ptr_t) r->fails[i]); free((ptr_t) r->realtrans); free((ptr_t) r->fails); free((ptr_t) r->newlines);}/*Having found the postfix representation of the regular expression,try to find a long sequence of characters that must appear in any linecontaining the r.e.Finding a "longest" sequence is beyond the scope here;we take an easy way out and hope for the best.(Take "(ab|a)b"--please.)We
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:Grep ƒ:dfa.c
+++++ Continued from previous card +++++
do a bottom-up calculation of sequences of characters that must appearin matches of r.e.'s represented by trees rooted at the nodes of the postfixrepresentation: sequences that must appear at the left of the match ("left") sequences that must appear at the right of the match ("right") lists of sequences that must appear somewhere in the match ("in") sequences that must constitute the match ("is")When we get to the root of the tree, we use one of the longest of itscalculated "in" sequences as our answer. The sequence we find is returned inr->must (where "r" is the single argument passed to "regmust");the length of the sequence is returned in r->mustn.The sequences calculated for the various types of node (in pseudo ANSI c)are shown below. "p" is the operand of unary operators (and the left-handoperand of binary operators); "q" is the right-hand operand of binary operators."ZERO" means "a zero-length sequence" below.Type left right is in---- ---- ----- -- --char c # c # c # c # cSET ZERO ZERO ZERO ZEROSTAR ZERO ZERO ZERO ZEROQMARK ZERO ZERO ZERO ZEROPLUS p->left p->right ZERO p->inCAT (p->is==ZERO)? (q->is==ZERO)? (p->is!=ZERO && p->in plus p->left : q->right : q->is!=ZERO) ? q->in plus p->is##q->left p->right##q->is p->is##q->is : p->right##q->left ZEROOR longest common longest common (do p->is and substrings common to leading trailing q->is have same p->in and q->in (sub)sequence (sub)sequence length and of p->left of p->right content) ? and q->left and q->right p->is : NULL If there's anything else we recognize in the tree, all four sequences get setto zero-length sequences. If there's something we don't recognize in the tree,we just return a zero-length sequence.Break ties in favor of infrequent letters (choosing 'zzz' in preference to'aaa')?And. . .is it here or someplace that we might ponder "optimizations" such as egrep 'psi|epsilon' -> egrep 'psi' egrep 'pepsi|epsilon' -> egrep 'epsi' (Yes, we now find "epsi" as a "string that must occur", but we might also simplify the *entire* r.e. being sought) grep '[c]' -> grep 'c' grep '(ab|a)b' -> grep 'ab' grep 'ab*' -> grep 'a' grep 'a*b' -> grep 'b'There are several issues: Is optimization easy (enough)? Does optimization actually accomplish anything, or is the automaton you get from "psi|epsilon" (for example) the same as the one you get from "psi" (for example)? Are optimizable r.e.'s likely to be used in real-life situations (something like 'ab*' is probably unlikely; something like is 'psi|epsilon' is likelier)?*/static char *icatalloc(old, new)char * old;char * new;{ register char * result; register int oldsize, newsize; newsize = (new == NULL) ? 0 : strlen(new); if (old == NULL) oldsize = 0; else if (newsize == 0) return old; else oldsize = strlen(old); if (old == NULL) result = (char *) malloc(newsize + 1); else result = (char *) realloc((void *) old, oldsize + newsize + 1); if (result != NULL && new != NULL) (void) strcpy(result + oldsize, new); return result;}static char *icpyalloc(string)const char * string;{ return icatalloc((char *) NULL, string);}static char *istrstr(lookin, lookfor)char * lookin;register char * lookfor;{ register char * cp; register int len; len = strlen(lookfor); for (cp = lookin; *cp != '\0'; ++cp) if (strncmp(cp, lookfor, len) == 0) return cp; return NULL;}static voidifree(cp)char * cp;{ if (cp != NULL) free(cp);}static voidfreelist(cpp)register char ** cpp;{ register int i; if (cpp == NULL) return; for (i = 0; cpp[i] != NULL; ++i) { free(cpp[i]); cpp[i] = NULL; }}static char **enlist(cpp, new, len)register char ** cpp;register char * new;{ register int i, j; if (cpp == NULL) return NULL; if ((new = icpyalloc(new)) == NULL) { freelist(cpp); return NULL; } new[len] = '\0'; /* ** Is there already something in the list that's new (or longer)? */ for (i = 0; cpp[i] != NULL; ++i) if (istrstr(cpp[i], new) != NULL) { free(new); return cpp; } /* ** Eliminate any obsoleted strings. */ j = 0; while (cpp[j] != NULL) if (istrstr(new, cpp[j]) == NULL) ++j; else { free(cpp[j]); if (--i == j) break; cpp[j] = cpp[i]; } /* ** Add the new string. */ cpp = (char **) realloc((char *) cpp, (i + 2) * sizeof *cpp); if (cpp == NULL) return NULL; cpp[i] = new; cpp[i + 1] = NULL; return cpp;}/*** Given pointers to two strings,** return a pointer to an allocated list of their distinct common substrings.** Return NULL if something seems wild.*/static char **comsubs(left, right)char * left;char * right;{ register char ** cpp; register char * lcp; register char * rcp; register int i, len; if (left == NULL || right == NULL) return NULL; cpp = (char **) malloc(sizeof *cpp); if (cpp == NULL) return NULL; cpp[0] = NULL; for (lcp = left; *lcp != '\0'; ++lcp) { len = 0; rcp = strchr(right, *lcp); while (rcp != NULL) { for (i = 1; lcp[i] != '\0' && lcp[i] == rcp[i]; ++i) ; if (i > len) len = i; rcp = strchr(rcp + 1, *lcp); } if (len == 0) continue; if ((cpp = enlist(cpp, lcp, len)) == NULL) break; } return cpp;}static char **addlists(old, new)char ** old;char ** new;{ register int i; if (old == NULL || new == NULL) return NULL; for (i = 0; new[i] != NULL; ++i) { old = enlist(old, new[i], strlen(new[i])); if (old == NULL) break; } return old;}/*** Given two lists of substrings,** return a new list giving substrings common to both.*/static char **inboth(left, right)char ** left;char ** right;{ register char ** both; register char ** temp; register int lnum, rnum; if (left == NULL || right == NULL) return NULL; both = (char **) malloc(sizeof *both); if (both == NULL) return NULL; both[0] = NULL; for (lnum = 0; left[lnum] != NULL; ++lnum) { for (rnum = 0; right[rnum] != NULL; ++rnum) { temp = comsubs(left[lnum], right[rnum]); if (temp == NULL) { freelist(both); return NULL; } both = addlists(both, temp); freelist(temp); if (both == NULL) return NULL; } } return both;}typedef struct { char ** in; char * left; char * right; char * is;} must;static voidresetmust(mp)register must * mp;{ mp->left[0] = mp->right[0] = mp->is[0] = '\0'; freelist(mp->in);}static voidregmust(r)register struct regexp * r;{ register must * musts; register must * mp; register char * result; register int ri; register int i; register _token t; static must must0; reg->mustn = 0; reg->must[0] = '\0'; musts = (must *) malloc((reg->tindex + 1) * sizeof *musts); if (musts == NULL) return; mp = musts; for (i = 0; i <= reg->tindex; ++i) mp[i] = must0; for (i = 0; i <= reg->tindex; ++i) { mp[i].in = (char **) malloc(sizeof *mp[i].in); mp[i].left = malloc(2); mp[i].right = malloc(2); mp[i].is = malloc(2); if (mp[i].in == NULL || mp[i].left == NULL || mp[i].right == NULL || mp[i].is == NULL) goto done; mp[i].left[0] = mp[i].right[0] = mp[i].is[0] = '\0'; mp[i].in[0] = NULL; } result = ""; for (ri = 0; ri < reg->tindex; ++ri) { switch (t = reg->tokens[ri]) { case _ALLBEGLINE: case _ALLENDLINE: case _LPAREN: case _RPAREN: goto done; /* "cannot happen" */ case _EMPTY: case _BEGLINE: case _ENDLINE: case _BEGWORD: case _ENDWORD: case _LIMWORD: case _NOTLIMWORD: case _BACKREF: resetmust(mp); break; case _STAR: case _QMARK: if (mp <= musts) goto done; /* "cannot happen" */ --mp; resetmust(mp); break; case _OR: if (mp < &musts[2]) goto done; /* "cannot happen" */ { register char ** new; register must * lmp; register must * rmp; register int j, ln, rn, n; rmp = --mp; lmp = --mp; /* Guaranteed to be. Unlikely, but. . . */ if (strcmp(lmp->is, rmp->is) != 0) lmp->is[0] = '\0'; /* Left side--easy */ i = 0; while (lmp->left[i] != '\0' && lmp->left[i] == rmp->left[i]) ++i; lmp->left[i] = '\0'; /* Right side */ ln = strlen(lmp->right); rn = strlen(rmp->right); n = ln; if (n > rn) n = rn; for (i = 0; i < n; ++i) if (lmp->right[ln - i - 1] != rmp->right[rn - i - 1]) break; for (j = 0; j < i; ++j) lmp->right[j] = lmp->right[(ln - i) + j]; lmp->right[j] = '\0'; new = inboth(lmp->in, rmp->in); if (new == NULL) goto done; freelist(lmp->in); free((char *) lmp->in); lmp->in = new; } break; case _PLUS: if (mp <= musts) goto done; /* "cannot happen" */ --mp; mp->is[0] = '\0'; break; case _END: if (mp != &musts[1]) goto done; /* "cannot happen" */ for (i = 0; musts[0].in[i] != NULL; ++i) if (strlen(musts[0].in[i]) > strlen(result)) result = musts[0].in[i]; goto done; case _CAT: if (mp < &musts[2]) goto done; /* "cannot happen" */ { register must * lmp; register must * rmp; rmp = --mp; lmp = --mp; /* ** In. Everything in left, plus everything in ** right, plus catenation of ** left's right and right's left. */ lmp->in = addlists(lmp->in, rmp->in); if (lmp->in == NULL) goto done; if (lmp->right[0] != '\0' && rmp->left[0] != '\0') { register char * tp; tp = icpyalloc(lmp->right); if (tp == NULL) goto done; tp = icatalloc(tp, rmp->left); if (tp == NULL) goto done; lmp->in = enlist(lmp->in, tp, strlen(tp)); free(tp); if (lmp->in == NULL) goto done; } /* Left-hand */ if (lmp->is[0] != '\0') { lmp->left = icatalloc(lmp->left, rmp->left); if (lmp->left == NULL) goto done; } /* Right-hand */ if (rmp->is[0] == '\0') lmp->right[0] = '\0'; lmp->right = icatalloc(lmp->right, rmp->right); if (lmp->right == NULL) goto done; /* Guaranteed to be */ if (lmp->is[0] != '\0' && rmp->is[0] != '\0') { lmp->is = icatalloc(lmp->is, rmp->is); if (lmp->is == NULL) goto done; } } break; default: if (t < _END) { /* "cannot happen" */ goto done; } else if (t == '\0') { /* not on *my* shift */ goto done; } else if (t >= _SET) { /* easy enough */ resetmust(mp); } else { /* plain character */ resetmust(mp); mp->is[0] = mp->left[0] = mp->right[0] = t; mp->is[1] = mp->left[1] = mp->right[1] = '\0'; mp->in = enlist(mp->in, mp->is, 1); if (mp->in == NULL) goto done; } break; } ++mp; }done: (void) strncpy(reg->must, result, MUST_MAX - 1); reg->must[MUST_MAX - 1] = '\0'; reg->mustn = strlen(reg->must); mp = musts; for (i = 0; i <= reg->tindex; ++i) { freelist(mp[i].in); ifree((char *) mp[i].in); ifree(mp[i].left); ifree(mp[i].right); ifree(mp[i].is); } free((char *) mp);} :MPW:MPW Tools:Tools with Source:Grep ƒ:dfa.h
/* dfa.h - declarations for GNU deterministic regexp compiler Copyright (C) 1988 Free Software Foundation, Inc. Written June, 1988 by Mike Haertel NO WARRANTY BECAUSE THIS PROGRAM IS LICENSED FREE OF CHARGE, WE PROVIDE ABSOLUTELYNO WARRANTY, TO THE EXTENT PERMITTED BY APPLICABLE STATE LAW. EXCEPTWHEN OTHERWISE STATED IN WRITING, FREE SOFTWARE FOUNDATION, INC,RICHARD M. STALLMAN AND/OR OTHER PARTIES PROVIDE THIS PROGRAM "AS IS"WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING,BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY ANDFITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITYAND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVEDEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR ORCORRECTION. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW WILL RICHARD M.STALLMAN, THE FREE SOFTWARE FOUNDATION, INC., AND/OR ANY OTHER PARTYWHO MAY MODIFY AND REDISTRIBUTE THIS PROGRAM AS PERMITTED BELOW, BELIABLE TO YOU FOR DAMAGES, INCLUDING ANY LOST PROFITS, LOST MONIES, OROTHER SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THEUSE OR INABILITY TO USE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA ORDATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY THIRD PARTIES ORA FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS) THISPROGRAM, EVEN IF YOU HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCHDAMAGES, OR FOR ANY CLAIM BY ANY OTHER PARTY. GENERAL PUBLIC LICENSE TO COPY 1. You may copy and distribute verbatim copies of this source fileas you receive it, in any medium, provided that you conspicuously andappropriately publish on each copy a valid copyright notice "Copyright (C) 1988 Free Software Foundation, Inc."; and include following thecopyright notice a verbatim copy of the above disclaimer of warrantyand of this License. You may charge a distribution fee for thephysical act of transferring a copy. 2. You may modify your copy or copies of this source file orany portion of it, and copy and distribute such modifications underthe terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains or is a derivative of this program or any part thereof, to be licensed at no charge to all third parties on terms identical to those contained in this License Agreement (except that you may choose to grant more extensive warranty protection to some or all third parties, at your option). c) You may charge a distribution fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee.Mere aggregation of another unrelated program with this program (or itsderivative) on a volume of a storage or distribution medium does not bringthe other program under the scope of these terms. 3. You may copy and distribute this program or any portion of it incompiled, executable or object code form under the terms of Paragraphs1 and 2 above provided that you do the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal shipping charge) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.)For an executable file, complete source code means all the source code forall modules it contains; but, as a special exception, it need not includesource code for modules which are standard libraries that accompany theoperating system on which the executable file runs. 4. You may not copy, sublicense, distribute or transfer this programexcept as expressly provided under this License Agreement. Any attemptotherwise to copy, sublicense, distribute or transfer this program is void andyour rights to use the program under this License agreement shall beautomatically terminated. However, parties who have received computersoftware programs from you with this License Agreement will not havetheir licenses terminated so long as such parties remain in full compliance. 5. If you wish to incorporate parts of this program into other freeprograms whose distribution conditions are different, write to the FreeSoftware Foundation at 675 Mass Ave, Cambridge, MA 02139. We have not yetworked out a simple rule that can be stated here, but we will often permitthis. We will be guided by the two goals of preserving the free status ofall derivatives our free software and of promoting the sharing and reuse ofsoftware.In other words, you are welcome to use, share and improve this program.You are forbidden to forbid anyone else to use, share and improvewhat you give them. Help stamp out software-hoarding! */#ifdef USG#include <string.h>extern char *index();#else#include <strings.h>extern char *strchr(), *strrchr(), *memcpy();#endif#ifdef __STDC__/* Missing include files for GNU C. *//* #include <stdlib.h> */typedef int size_t; extern void *calloc(int, size_t);extern void *malloc(size_t);extern void *realloc(void *, size_t);extern void free(void *);extern char *bcopy(), *bzero();#ifdef SOMEDAY#define ISALNUM(c) isalnum(c)#define ISALPHA(c) isalpha(c)#else#define ISALNUM(c) (isascii(c) && isalnum(c))#define ISALPHA(c) (isascii(c) && isalpha(c))#endif#else /* ! __STDC__ */#define const#ifndef macintosh /* MPW C 3.0 defines size_t - DDZ 8:35:48 PM 3/20/89 */typedef int size_t;#endifextern char *calloc(), *malloc(), *realloc();extern void free();extern char *bcopy(), *bzero();#define ISALNUM(c) (isascii(c) && isalnum(c))#define ISALPHA(c) (isascii(c) && isalpha(c))#endif /* ! __STDC__ *//* 1 means plain parentheses serve as grouping, and backslash parentheses are needed for literal searching. 0 means backslash-parentheses are grouping, and plain parentheses are for literal searching. */#define RE_NO_BK_PARENS 1/* 1 means plain | serves as the "or"-operator, and \| is a literal. 0 means \| serves as the "or"-operator, and | is a literal. */#define RE_NO_BK_VBAR 2/* 0 means plain + or ? serves as an operator, and \+, \? are literals. 1 means \+, \? are operators and plain +, ? are literals. */#define RE_BK_PLUS_QM 4/* 1 means | binds tighter than ^ or $. 0 means the contrary. */#define RE_TIGHT_VBAR 8/* 1 means treat \n as an _OR operator 0 means treat it as a normal character */#define RE_NEWLINE_OR 16/* 0 means that a special characters (such as *, ^, and $) always have their special meaning regardless of the surrounding context. 1 means that special characters may act as normal characters in some contexts. Specifically, this applies to: ^ - only special at the beginning, or after ( or | $ - only special at the end, or before ) or | *, +, ? - only special when not after the beginning, (, or | */#define RE_CONTEXT_INDEP_OPS 32/* Now define combinations of bits for the standard possibilities. */#define RE_SYNTAX_AWK (RE_NO_BK_PARENS | RE_NO_BK_VBAR | RE_CONTEXT_INDEP_OPS)#define RE_SYNTAX_EGREP (RE_SYNTAX_AWK | RE_NEWLINE_OR)#define RE_SYNTAX_GREP (RE_BK_PLUS_QM | RE_NEWLINE_OR)#define RE_SYNTAX_EMACS 0/* The NULL pointer. */#define NULL 0/* Number of bits in an unsigned char. */#define CHARBITS 8/* First integer value that is greater than any character code. */#define _NOTCHAR (1 << CHARBITS)/* INTBITS need not be exact, just a lower bound. */#define INTBITS (CHARBITS * sizeof (int))/* Number of ints required to hold a bit for every character. */#define _CHARSET_INTS ((_NOTCHAR + INTBITS - 1) / INTBITS)/* Sets of unsigned characters are stored as bit vectors in arrays of ints. */typedef int _charset[_CHARSET_INTS];/* The regexp is parsed into an array of tokens in postfix form. Some tokens are operators and others are terminal symbols. Most (but not all) of these codes are returned by the lexical analyzer. */#ifdef __STDC__typedef enum{ _END = -1, /* _END is a terminal symbol that matches the end of input; any value of _END or less in the parse tree is such a symbol. Accepting states of the DFA are those that would have a transition on _END. */ /* Ordinary character values are terminal symbols that match themselves. */ _EMPTY = _NOTCHAR, /* _EMPTY is a terminal symbol that matches the empty string. */ _BACKREF, CKREF is generated by \<digit>; it it not completely handled. If the scanner detects a transition on backref, it returns a kind of "semi-success" indicating that the match will have to be verified with a backtracking matcher. */ _BEGLINE, /* _BEGLINE is a terminal symbol that matches the empty string if it is at the beginning of a line. */ _ALLBEGLINE, /* _ALLBEGLINE is a terminal symbol that matches the empty string if it is at the beginning of a line; _ALLBEGLINE applies to the entire regexp and can only occur as the first token thereof. _ALLBEGLINE never appears in the parse tree; a _BEGLINE is prepended with _CAT to the entire regexp instead. */ _ENDLINE, /* _ENDLINE is a terminal symbol that matches the empty string if it is at the end of a line. */ _ALLENDLINE, /* _ALLENDLINE is to _ENDLINE as _ALLBEGLINE is to _BEGLINE. */ _BEGWORD, /* _BEGWORD is a terminal symbol that matches the empty string if it is at the beginning of a word. */ _ENDWORD, /* _ENDWORD is a terminal symbol that matches the empty string if it is at the end of a word. */ _LIMWORD, /* _LIMWORD is a terminal symbol that matches the empty string if it is at the beginning or the end of a word. */ _NOTLIMWORD, /* _NOTLIMWORD is a terminal symbol that matches the empty string if it is not at the beginning or end of a word. */ _QMARK, /* _QMARK is an operator of one argument that matches zero or one occurences of its argument. */ _STAR, /* _STAR is an operator of one argument that matches the Kleene closure (zero or more occurrences) of its argument. */ _PLUS, /* _PLUS is an operator of one argument that matches the positive closure (one or more occurrences) of its argument. */ _CAT, /* _CAT is an operator of two arguments that matches the concatenation of its arguments. _CAT is never returned by the lexical analyzer. */ _OR, /* _OR is an operator of two arguments that matches either of its arguments. */ _LPAREN, /* _LPAREN never appears in the parse tree, it is only a lexeme. */ _RPAREN, /* _RPAREN never appears in the parse tree. */ _SET /* _SET and (and any value greater) is a terminal symbol that matches any of a class of characters. */} _token;#else /* ! __STDC__ */typedef short _token;#define _END -1#define _EMPTY _NOTCHAR#define _BACKREF (_EMPTY + 1)#define _BEGLINE (_EMPTY + 2)#define _ALLBEGLINE (_EMPTY + 3)#define _ENDLINE (_EMPTY + 4)#define _ALLENDLINE (_EMPTY + 5)#define _BEGWORD (_EMPTY + 6)#define _ENDWORD (_EMPTY + 7)#define _LIMWORD (_EMPTY + 8)#define _NOTLIMWORD (_EMPTY + 9)#define _QMARK (_EMPTY + 10)#define _STAR (_EMPTY + 11)#define _PLUS (_EMPTY + 12)#define _CAT (_EMPTY + 13)#define _OR (_EMPTY + 14)#define _LPAREN (_EMPTY + 15)#define _RPAREN (_EMPTY + 16)#define _SET (_EMPTY + 17)#endif /* ! __STDC__ *//* Sets are stored in an array in the compiled regexp; the index of the array corresponding to a given set token is given by _SET_INDEX(t). */#define _SET_INDEX(t) ((t) - _SET)/* Sometimes characters can only be matched depending on the surrounding context. Such context decisions depend on what the previous character was, and the value of the current (lookahead) character. Context dependent constraints are encoded as 8 bit integers. Each bit that is set indicates that the constraint succeeds in the corresponding context. bit 7 - previous and current are newlines bit 6 - previous was newline, current isn't bit 5 - previous wasn't newline, current is bit 4 - neither previous nor current is a newline bit 3 - previous and current are word-constituents bit 2 - previous was word-constituent, current isn't bit 1 - previous wasn't word-constituent, current is bit 0 - neither previous nor current is word-constituent Word-constituent characters are those that satisfy isalnum(). The macro _SUCCEEDS_IN_CONTEXT determines whether a a given constraint succeeds in a particular context. Prevn is true if the previous character was a newline, currn is true if the lookahead character is a newline. Prevl and currl similarly depend upon whether the previous and current characters are word-constituent letters. */#define _MATCHES_NEWLINE_CONTEXT(constraint, prevn, currn) \ ((constraint) & 1 << ((prevn) ? 2 : 0) + ((currn) ? 1 : 0) + 4)#define _MATCHES_LETTER_CONTEXT(constraint, prevl, currl) \ ((constraint) & 1 << ((prevl) ? 2 : 0) + ((currl) ? 1 : 0))#define _SUCCEEDS_IN_CONTEXT(constraint, prevn, currn, prevl, currl) \ (_MATCHES_NEWLINE_CONTEXT(constraint, prevn, currn) \ && _MATCHES_LETTER_CONTEXT(constraint, prevl, currl))/* The following macros give information about what a constraint depends on. */#define _PREV_NEWLINE_DEPENDENT(constraint) \ (((constraint) & 0xc0) >> 2 != ((constraint) & 0x30))#define _PREV_LETTER_DEPENDENT(constraint) \ (((constraint) & 0x0c) >> 2 != ((constraint) & 0x03))/* Tokens that match the empty string subject to some constraint actually work by applying that constraint to determine what may follow them, taking into account what has gone before. The following values are the constraints corresponding to the special tokens previously defined. */#define _NO_CONSTRAINT 0xff#define _BEGLINE_CONSTRAINT 0xcf#define _ENDLINE_CONSTRAINT 0xaf#define _BEGWORD_CONSTRAINT 0xf2#define _ENDWORD_CONSTRAINT 0xf4#define _LIMWORD_CONSTRAINT 0xf6#define _NOTLIMWORD_CONSTRAINT 0xf9/* States of the recognizer correspond to sets of positions in the parse tree, together with the constraints under which they may be matched. So a position is encoded as an index into the parse tree together with a constraint. */typedef struct{ unsigned index; /* Index into the parse array. */ unsigned constraint; /* Constraint for matching this position. */} _position;/* Sets of positions are stored as arrays. */typedef struct{ _position *elems; /* Elements of this position set. */ int nelem; /* Number of elements in this set. */} _position_set;/* A state of the regexp consists of a set of positions, some flags, and the token value of the lowest-numbered position of the state that contains an _END token. */typedef struct{ int hash; /* Hash of the positions of this state. */ _position_set elems; /* Positions this state could match. */ char newline; /* True if previous state matched newline. */ char letter; /* True if previous state matched a letter. */ char backref; /* True if this state matches a \<dig
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:Grep ƒ:dfa.h
+++++ Continued from previous card +++++
it>. */ unsigned char constraint; /* Constraint for this state to accept. */ int first_end; /* Token value of the first _END in elems. */} _dfa_state;/* If an r.e. is at most MUST_MAX characters long, we look for a string which must appear in it; whatever's found is dropped into the struct reg. */#define MUST_MAX 50/* A compiled regular expression. */struct regexp{ /* Stuff built by the scanner. */ _charset *charsets; /* Array of character sets for _SET tokens. */ int cindex; /* Index for adding new charsets. */ int calloc; /* Number of charsets currently allocated. */ /* Stuff built by the parser. */ _token *tokens; /* Postfix parse array. */ int tindex; /* Index for adding new tokens. */ int talloc; /* Number of tokens currently allocated. */ int depth; /* Depth required of an evaluation stack used for depth-first traversal of the parse tree. */ int nleaves; /* Number of leaves on the parse tree. */ int nregexps; /* Count of parallel regexps being built with regparse(). */ /* Stuff owned by the state builder. */ _dfa_state *states; /* States of the regexp. */ int sindex; /* Index for adding new states. */ int salloc; /* Number of states currently allocated. */ /* Stuff built by the structure analyzer. */ _position_set *follows; /* Array of follow sets, indexed by position index. The follow of a position is the set of positions containing characters that could conceivably follow a character matching the given position in a string matching the regexp. Allocated to the maximum possible position index. */ int searchflag; /* True if we are supposed to build a searching as opposed to an exact matcher. A searching matcher finds the first and shortest string matching a regexp anywhere in the buffer, whereas an exact matcher finds the longest string matching, but anchored to the beginning of the buffer. */ /* Stuff owned by the executor. */ int tralloc; /* Number of transition tables that have slots so far. */ int trcount; /* Number of transition tables that have actually been built. */ int **trans; /* Transition tables for states that can never accept. If the transitions for a state have not yet been computed, or the state could possibly accept, its entry in this table is NULL. */ int **realtrans; /* Trans always points to realtrans + 1; this is so trans[-1] can contain NULL. */ int **fails; /* Transition tables after failing to accept on a state that potentially could do so. */ int *success; /* Table of acceptance conditions used in regexecute and computed in build_state. */ int *newlines; /* Transitions on newlines. The entry for a newline in any transition table is always -1 so we can count lines without wasting too many cycles. The transition for a newline is stored separately and handled as a special case. Newline is also used as a sentinel at the end of the buffer. */ char must[MUST_MAX]; int mustn;};/* Some macros for user access to regexp internals. *//* ACCEPTING returns true if s could possibly be an accepting state of r. */#define ACCEPTING(s, r) ((r).states[s].constraint)/* ACCEPTS_IN_CONTEXT returns true if the given state accepts in the specified context. */#define ACCEPTS_IN_CONTEXT(prevn, currn, prevl, currl, state, reg) \ _SUCCEEDS_IN_CONTEXT((reg).states[state].constraint, \ prevn, currn, prevl, currl)/* FIRST_MATCHING_REGEXP returns the index number of the first of parallel regexps that a given state could accept. Parallel regexps are numbered starting at 1. */#define FIRST_MATCHING_REGEXP(state, reg) (-(reg).states[state].first_end)/* Entry points. */#ifdef __STDC__/* Regsyntax() takes two arguments; the first sets the syntax bits described earlier in this file, and the second sets the case-folding flag. */extern void regsyntax(int, int);/* Compile the given string of the given length into the given struct regexp. Final argument is a flag specifying whether to build a searching or an exact matcher. */extern void regcompile(const char *, size_t, struct regexp *, int);/* Execute the given struct regexp on the buffer of characters. The first char * points to the beginning, and the second points to the first character after the end of the buffer, which must be a writable place so a sentinel end-of-buffer marker can be stored there. The second-to-last argument is a flag telling whether to allow newlines to be part of a string matching the regexp. The next-to-last argument, if non-NULL, points to a place to increment every time we see a newline. The final argument, if non-NULL, points to a flag that will be set if further examination by a backtracking matcher is needed in order to verify backreferencing; otherwise the flag will be cleared. Returns NULL if no match is found, or a pointer to the first character after the first & shortest matching string in the buffer. */extern char *regexecute(struct regexp *, char *, char *, int, int *, int *);/* Free the storage held by the components of a struct regexp. */extern void regfree(struct regexp *);/* Entry points for people who know what they're doing. *//* Initialize the components of a struct regexp. */extern void reginit(struct regexp *);/* Incrementally parse a string of given length into a struct regexp. */extern void regparse(const char *, size_t, struct regexp *);/* Analyze a parsed regexp; second argument tells whether to build a searching or an exact matcher. */extern void reganalyze(struct regexp *, int);/* Compute, for each possible character, the transitions out of a given state, storing them in an array of integers. */extern void regstate(int, struct regexp *, int []);/* Error handling. *//* Regerror() is called by the regexp routines whenever an error occurs. It takes a single argument, a NUL-terminated string describing the error. The default regerror() prints the error message to stderr and exits. The user can provide a different regfree() if so desired. */extern void regerror(const char *);#else /* ! __STDC__ */extern void regsyntax(), regcompile(), regfree(), reginit(), regparse();extern void reganalyze(), regstate(), regerror();extern char *regexecute();#endif :MPW:MPW Tools:Tools with Source:Grep ƒ:getopt.c
/* Getopt for GNU. Copyright (C) 1987 Free Software Foundation, Inc. NO WARRANTY BECAUSE THIS PROGRAM IS LICENSED FREE OF CHARGE, WE PROVIDE ABSOLUTELYNO WARRANTY, TO THE EXTENT PERMITTED BY APPLICABLE STATE LAW. EXCEPTWHEN OTHERWISE STATED IN WRITING, FREE SOFTWARE FOUNDATION, INC,RICHARD M. STALLMAN AND/OR OTHER PARTIES PROVIDE THIS PROGRAM "AS IS"WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING,BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY ANDFITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITYAND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVEDEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR ORCORRECTION. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW WILL RICHARD M.STALLMAN, THE FREE SOFTWARE FOUNDATION, INC., AND/OR ANY OTHER PARTYWHO MAY MODIFY AND REDISTRIBUTE THIS PROGRAM AS PERMITTED BELOW, BELIABLE TO YOU FOR DAMAGES, INCLUDING ANY LOST PROFITS, LOST MONIES, OROTHER SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THEUSE OR INABILITY TO USE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA ORDATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY THIRD PARTIES ORA FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS) THISPROGRAM, EVEN IF YOU HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCHDAMAGES, OR FOR ANY CLAIM BY ANY OTHER PARTY. GENERAL PUBLIC LICENSE TO COPY 1. You may copy and distribute verbatim copies of this source fileas you receive it, in any medium, provided that you conspicuously andappropriately publish on each copy a valid copyright notice "Copyright (C) 1987 Free Software Foundation, Inc."; and include following thecopyright notice a verbatim copy of the above disclaimer of warrantyand of this License. You may charge a distribution fee for thephysical act of transferring a copy. 2. You may modify your copy or copies of this source file orany portion of it, and copy and distribute such modifications underthe terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains or is a derivative of this program or any part thereof, to be licensed at no charge to all third parties on terms identical to those contained in this License Agreement (except that you may choose to grant more extensive warranty protection to third parties, at your option). c) You may charge a distribution fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 3. You may copy and distribute this program or any portion of it incompiled, executable or object code form under the terms of Paragraphs1 and 2 above provided that you do the following: a) cause each such copy to be accompanied by the corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) cause each such copy to be accompanied by a written offer, with no time limit, to give any third party free (except for a nominal shipping charge) a machine readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) in the case of a recipient of this program in compiled, executable or object code form (without the corresponding source code) you shall cause copies you distribute to be accompanied by a copy of the written offer of source code which you received along with the copy you received. 4. You may not copy, sublicense, distribute or transfer this programexcept as expressly provided under this License Agreement. Any attemptotherwise to copy, sublicense, distribute or transfer this program is void andyour rights to use the program under this License agreement shall beautomatically terminated. However, parties who have received computersoftware programs from you with this License Agreement will not havetheir licenses terminated so long as such parties remain in full compliance. 5. If you wish to incorporate parts of this program into other freeprograms whose distribution conditions are different, write to the FreeSoftware Foundation at 675 Mass Ave, Cambridge, MA 02139. We have not yetworked out a simple rule that can be stated here, but we will often permitthis. We will be guided by the two goals of preserving the free status ofall derivatives of our free software and of promoting the sharing and reuse ofsoftware.In other words, you are welcome to use, share and improve this program.You are forbidden to forbid anyone else to use, share and improvewhat you give them. Help stamp out software-hoarding! */ /* This version of `getopt' appears to the caller like standard Unix `getopt' but it behaves differently for the user, since it allows the user to intersperse the options with the other arguments. As `getopt' works, it permutes the elements of `argv' so that, when it is done, all the options precede everything else. Thus all application programs are extended to handle flexible argument order. Setting the environment variable _POSIX_OPTION_ORDER disables permutation. Then the behavior is completely standard. GNU application programs can use a third alternative mode in which they can distinguish the relative order of options and other arguments. */#include <stdio.h>#ifdef sparc#include <alloca.h>#endif#ifdef USG#define bcopy(s, d, l) memcpy((d), (s), (l))#endif/* For communication from `getopt' to the caller. When `getopt' finds an option that takes an argument, the argument value is returned here. Also, when `ordering' is RETURN_IN_ORDER, each non-option ARGV-element is returned here. */char *optarg = 0;/* Index in ARGV of the next element to be scanned. This is used for communication to and from the caller and for communication between successive calls to `getopt'. On entry to `getopt', zero means this is the first call; initialize. When `getopt' returns EOF, this is the index of the first of the non-option elements that the caller should itself scan. Otherwise, `optind' communicates from one call to the next how much of ARGV has been scanned so far. */int optind = 0;/* The next char to be scanned in the option-element in which the last option character we returned was found. This allows us to pick up the scan where we left off. If this is zero, or a null string, it means resume the scan by advancing to the next ARGV-element. */static char *nextchar;/* Callers store zero here to inhibit the error message for unrecognized options. */int opterr = 1;/* Describe how to deal with options that follow non-option ARGV-elements. UNSPECIFIED means the caller did not specify anything; the default is then REQUIRE_ORDER if the environment variable _OPTIONS_FIRST is defined, PERMUTE otherwise. REQUIRE_ORDER means don't recognize them as options. Stop option processing when the first non-option is seen. This is what Unix does. PERMUTE is the default. We permute the contents of `argv' as we scan, so that eventually all the options are at the end. This allows options to be given in any order, even with programs that were not written to expect this. RETURN_IN_ORDER is an option available to programs that were written to expect options and other ARGV-elements in any order and that care about the ordering of the two. We describe each non-option ARGV-element as if it were the argument of an option with character code zero. Using `-' as the first character of the list of option characters requests this mode of operation. The special argument `--' forces an end of option-scanning regardless of the value of `ordering'. In the case of RETURN_IN_ORDER, only `--' can cause `getopt' to return EOF with `optind' != ARGC. */static enum { REQUIRE_ORDER, PERMUTE, RETURN_IN_ORDER } ordering; /* Handle permutation of arguments. *//* Describe the part of ARGV that contains non-options that have been skipped. `first_nonopt' is the index in ARGV of the first of them; `last_nonopt' is the index after the last of them. */static int first_nonopt;static int last_nonopt;/* Exchange two adjacent subsequences of ARGV. One subsequence is elements [first_nonopt,last_nonopt) which contains all the non-options that have been skipped so far. The other is elements [last_nonopt,optind), which contains all the options processed since those non-options were skipped. `first_nonopt' and `last_nonopt' are relocated so that they describe the new indices of the non-options in ARGV after they are moved. */static voidexchange (argv) char **argv;{ int nonopts_size = (last_nonopt - first_nonopt) * sizeof (char *); char **temp = (char **) alloca (nonopts_size); /* Interchange the two blocks of data in argv. */ bcopy (&argv[first_nonopt], temp, nonopts_size); bcopy (&argv[last_nonopt], &argv[first_nonopt], (optind - last_nonopt) * sizeof (char *)); bcopy (temp, &argv[first_nonopt + optind - last_nonopt], nonopts_size); /* Update records for the slots the non-options now occupy. */ first_nonopt += (optind - last_nonopt); last_nonopt = optind;} /* Scan elements of ARGV (whose length is ARGC) for option characters given in OPTSTRING. If an element of ARGV starts with '-', and is not exactly "-" or "--", then it is an option element. The characters of this element (aside from the initial '-') are option characters. If `getopt' is called repeatedly, it returns successively each of theoption characters from each of the option elements. If `getopt' finds another option character, it returns that character, updating `optind' and `nextchar' so that the next call to `getopt' can resume the scan with the following option character or ARGV-element. If there are no more option characters, `getopt' returns `EOF'. Then `optind' is the index in ARGV of the first ARGV-element that is not an option. (The ARGV-elements have been permuted so that those that are not options now come last.) OPTSTRING is a string containing the legitimate option characters. A colon in OPTSTRING means that the previous character is an option that wants an argument. The argument is taken from the rest of the current ARGV-element, or from the following ARGV-element, and returned in `optarg'. If an option character is seen that is not listed in OPTSTRING, return '?'rinting an error message. If you set `opterr' to zero, the error message is suppressed but we still return '?'. If a char in OPTSTRING is followed by a colon, that means it wants an arg, so the following text in the same ARGV-element, or the text of the following ARGV-element, is returned in `optarg. Two colons mean an option that wants an optional arg; if there is text in the current ARGV-element, it is returned in `optarg'. If OPTSTRING starts with `-', it requests a different method of handling the non-option ARGV-elements. See the comments about RETURN_IN_ORDER, above. */intgetopt (argc, argv, optstring) int argc; char **argv; char *optstring;{ /* Initialize the internal data when the first call is made. Start processing options with ARGV-element 1 (since ARGV-element 0 is the program name); the sequence of previously skipped non-option ARGV-elements is empty. */ if (optind == 0) { first_nonopt = last_nonopt = optind = 1; nextchar = 0; /* Determine how to handle the ordering of options and nonoptions. */ if (optstring[0] == '-') ordering = RETURN_IN_ORDER; else if (getenv ("_POSIX_OPTION_ORDER") != 0) ordering = REQUIRE_ORDER; else ordering = PERMUTE; } if (nextchar == 0 || *nextchar == 0) { if (ordering == PERMUTE) { /* If we have just processed some options following some non-options, exchange them so that the options come first. */ if (first_nonopt != last_nonopt && last_nonopt != optind) exchange (argv); else if (last_nonopt != optind) first_nonopt = optind; /* Now skip any additional non-options and extend the range of non-options previously skipped. */ while (optind < argc && (argv[optind][0] != '-' || argv[optind][1] == 0)) optind++; last_nonopt = optind; } /* Special ARGV-element `--' means premature end of options. Skip it like a null option, then exchange with previous non-options as if it were an option, then skip everything else like a non-option. */ if (optind != argc && !strcmp (argv[optind], "--")) { optind++; if (first_nonopt != last_nonopt && last_nonopt != optind) exchange (argv); else if (first_nonopt == last_nonopt) first_nonopt = optind; last_nonopt = argc; optind = argc; } /* If we have done all the ARGV-elements, stop the scan and back over any non-options that we skipped and permuted. */ if (optind == argc) { /* Set the next-arg-index to point at the non-options that we previously skipped, so the caller will digest them. */ if (first_nonopt != last_nonopt) optind = first_nonopt; return EOF; } /* If we have come to a non-option and did not permute it, either stop the scan or describe it to the caller and pass it by. */ if (argv[optind][0] != '-' || argv[optind][1] == 0) { if (ordering == REQUIRE_ORDER) return EOF; optarg = argv[optind++]; return 0; } /* We have found another option-ARGV-element. Start decoding its characters. */ nextchar = argv[optind] + 1; } /* Look at and handle the next option-character. */ { char c = *nextchar++; char *temp = (char *) index (optstring, c); /* Increment `optind' when we start to process its last character. */ if (*nextchar == 0) optind++; if (temp == 0 || c == ':') { if (opterr != 0) { if (c < 040 || c >= 0177) fprintf (stderr, "%s: unrecognized option, character code 0%o\n", argv[0], c); else fprintf (stderr, "%s: unrecognized option `-%c'\n", argv[0], c); } return '?'; } if (temp[1] == ':') { if (temp[2] == ':') { /* This is an option that accepts an argument optionally. */ if (*nextchar != 0) { optarg = nextchar; optind++; } else optarg = 0; nextchar = 0; } else { /* This is an option that requires an argument. */ if (*nextchar != 0) { optarg = nextchar; /* If we end this ARGV-element by taking the rest as an arg, we must advance to the next element now. */ optind++; } else if (optind == argc) { if (opterr != 0) fprintf (stderr, "%s: no argument for `-%c' option\n", argv[0], c); c = '?'; } else /* We already incremented `optind' once; increment it again when taking next ARGV-elt as argument. */ optarg = argv[optind++]; nextchar = 0; } } return c; }} #ifdef TEST/* Compile with -DTEST to make an executable for use in testing the above definition of `getopt'. */intmain (argc, argv) int argc; char **argv;{ char c; int digit_optind = 0; while (1) { int this_option_optind = optind; if ((c = getopt (argc, argv, "abc:d:0123456789")) == EOF) break; switch (c) { case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': if (digit_optind != 0 && di
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:Grep ƒ:getopt.c
+++++ Continued from previous card +++++
git_optind != this_option_optind) printf ("digits occur in two different argv-elements.\n"); digit_optind = this_option_optind; printf ("option %c\n", c); break; case 'a': printf ("option a\n"); break; case 'b': printf ("option b\n"); break; case 'c': printf ("option c with value `%s'\n", optarg); break; case '?': break; default: printf ("?? getopt returned character code 0%o ??\n", c); } } if (optind < argc) { printf ("non-option ARGV-elements: "); while (optind < argc) printf ("%s ", argv[optind++]); printf ("\n"); } return 0;}#endif /* TEST */ :MPW:MPW Tools:Tools with Source:Grep ƒ:grep.c
/* grep - print lines matching an extended regular expression Copyright (C) 1988 Free Software Foundation, Inc. Written June, 1988 by Mike Haertel BMG speedups added July, 1988 by James A. Woods and Arthur David Olson NO WARRANTY BECAUSE THIS PROGRAM IS LICENSED FREE OF CHARGE, WE PROVIDE ABSOLUTELYNO WARRANTY, TO THE EXTENT PERMITTED BY APPLICABLE STATE LAW. EXCEPTWHEN OTHERWISE STATED IN WRITING, FREE SOFTWARE FOUNDATION, INC,RICHARD M. STALLMAN AND/OR OTHER PARTIES PROVIDE THIS PROGRAM "AS IS"WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING,BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY ANDFITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITYAND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVEDEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR ORCORRECTION. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW WILL RICHARD M.STALLMAN, THE FREE SOFTWARE FOUNDATION, INC., AND/OR ANY OTHER PARTYWHO MAY MODIFY AND REDISTRIBUTE THIS PROGRAM AS PERMITTED BELOW, BELIABLE TO YOU FOR DAMAGES, INCLUDING ANY LOST PROFITS, LOST MONIES, OROTHER SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THEUSE OR INABILITY TO USE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA ORDATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY THIRD PARTIES ORA FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS) THISPROGRAM, EVEN IF YOU HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCHDAMAGES, OR FOR ANY CLAIM BY ANY OTHER PARTY. GENERAL PUBLIC LICENSE TO COPY 1. You may copy and distribute verbatim copies of this source fileas you receive it, in any medium, provided that you conspicuously andappropriately publish on each copy a valid copyright notice "Copyright (C) 1988 Free Software Foundation, Inc."; and include following thecopyright notice a verbatim copy of the above disclaimer of warrantyand of this License. You may charge a distribution fee for thephysical act of transferring a copy. 2. You may modify your copy or copies of this source file orany portion of it, and copy and distribute such modifications underthe terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains or is a derivative of this program or any part thereof, to be licensed at no charge to all third parties on terms identical to those contained in this License Agreement (except that you may choose to grant more extensive warranty protection to some or all third parties, at your option). c) You may charge a distribution fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee.Mere aggregation of another unrelated program with this program (or itsderivative) on a volume of a storage or distribution medium does not bringthe other program under the scope of these terms. 3. You may copy and distribute this program or any portion of it incompiled, executable or object code form under the terms of Paragraphs1 and 2 above provided that you do the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal shipping charge) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.)For an executable file, complete source code means all the source code forall modules it contains; but, as a special exception, it need not includesource code for modules which are standard libraries that accompany theoperating system on which the executable file runs. 4. You may not copy, sublicense, distribute or transfer this programexcept as expressly provided under this License Agreement. Any attemptotherwise to copy, sublicense, distribute or transfer this program is void andyour rights to use the program under this License agreement shall beautomatically terminated. However, parties who have received computersoftware programs from you with this License Agreement will not havetheir licenses terminated so long as such parties remain in full compliance. 5. If you wish to incorporate parts of this program into other freeprograms whose distribution conditions are different, write to the FreeSoftware Foundation at 675 Mass Ave, Cambridge, MA 02139. We have not yetworked out a simple rule that can be stated here, but we will often permitthis. We will be guided by the two goals of preserving the free status ofall derivatives our free software and of promoting the sharing and reuse ofsoftware.In other words, you are welcome to use, share and improve this program.You are forbidden to forbid anyone else to use, share and improvewhat you give them. Help stamp out software-hoarding! */#include <ctype.h>#include <stdio.h>#ifdef USG#include <memory.h>#include <string.h>#else#include <strings.h>#endif#include "dfa.h"#include "regex.h"#ifdef __STDC__extern getopt(int, char **, const char *);extern read(int, void *, int);extern open(const char *, int, ...);extern void close();#elseextern char *strrchr();#endifextern char *optarg;extern optind, opterr;extern errno;extern char *sys_errlist[];#define MAX(a, b) ((a) > (b) ? (a) : (b))/* Exit status codes. */#define MATCHES_FOUND 0 /* Exit 0 if no errors and matches found. */#define NO_MATCHES_FOUND 1 /* Exit 1 if no matches were found. */#define ERROR 2 /* Exit 2 if some error occurred. *//* Error is set true if something awful happened. */static int error;/* The program name for error messages. */static char *prog;/* We do all our own buffering by hand for efficiency. */static char *buffer; /* The buffer itself, grown as needed. */static bufbytes; /* Number of bytes in the buffer. */static size_t bufalloc; /* Number of bytes allocated to the buffer. */static bufprev; /* Number of bytes that have been forgotten. This is used to get byte offsets from the beginning of the file. */static bufread; /* Number of bytes to get with each read(). */static voidinitialize_buffer(){ bufread = 8192; bufalloc = bufread + bufread / 2; buffer = malloc(bufalloc); if (! buffer) { fprintf(stderr, "%s: Memory exhausted (%s)\n", prog, sys_errlist[errno]); exit(ERROR); }}/* The current input file. */static fd;static char *filename;static eof;/* Fill the buffer retaining the last n bytes at the beginning of the newly filled buffer (for backward context). Returns the number of new bytes read from disk. */staticfill_buffer_retaining(n) int n;{ char *p, *q; int i; /* See if we need to grow the buffer. */ if (bufalloc - n <= bufread) { while (bufalloc - n <= bufread) { bufalloc *= 2; bufread *= 2; } buffer = realloc(buffer, bufalloc); if (! buffer) { fprintf(stderr, "%s: Memory exhausted (%s)\n", prog, sys_errlist[errno]); exit(ERROR); } } bufprev += bufbytes - n; /* Shift stuff down. */ for (i = n, p = buffer, q = p + bufbytes - n; i--; ) *p++ = *q++; bufbytes = n; if (eof) return 0; /* Read in new stuff. */ i = read(fd, buffer + bufbytes, bufread); if (i < 0) { fprintf(stderr, "%s: read on %s failed (%s)\n", prog, filename ? filename : "<stdin>", sys_errlist[errno]); error = 1; } /* Kludge to pretend every nonempty file ends with a newline. */ if (i == 0 && bufbytes > 0 && buffer[bufbytes - 1] != '\n') { eof = i = 1; buffer[bufbytes] = '\n'; } bufbytes += i; return i;}/* Various flags set according to the argument switches. */static trailing_context; /* Lines of context to show after matches. */static leading_context; /* Lines of context to show before matches. */static byte_count; /* Precede output lines the byte count of the first character on the line. */static no_filenames; /* Do not display filenames. */static line_numbers; /* Precede output lines with line numbers. */static silent; /* Produce no output at all. This switch is bogus, ever hear of /dev/null? */static nonmatching_lines; /* Print lines that don't match the regexp. */static bmgexec; /* Invoke Boyer-Moore-Gosper routines *//* The compiled regular expression lives here. */static struct regexp reg;/* The compiled regular expression for the backtracking matcher lives here. */static struct re_pattern_buffer regex;/* Pointer in the buffer after the last character printed. */static char *printed_limit;/* True when printed_limit has been artifically advanced without printing anything. */static int printed_limit_fake;/* Print a line at the given line number, returning the number of characters actually printed. Matching is true if the line is to be considered a "matching line". This is only meaningful if surrounding context is turned on. */staticprint_line(p, number, matching) char *p; int number; int matching;{ int count = 0; if (silent) { do ++count; while (*p++ != '\n'); printed_limit_fake = 0; printed_limit = p; return count; } if (filename && !no_filenames)#ifdef macintosh printf("File \"%s\"", filename);#else printf("%s", filename);#endif if (byte_count) printf("%d", p - buffer + bufprev); if (line_numbers)#ifdef macintosh printf("; Line %d", number);#else printf("%d", number);#endif printf (" #%c", matching ? ' ' : '#'); do { ++count; putchar(*p); } while (*p++ != '\n'); printed_limit_fake = 0; printed_limit = p; return count;}/* Print matching or nonmatching lines from the current file. Returns a count of matching or nonmatching lines. */staticgrep(){ int retain = 0; /* Number of bytes to retain on next call to fill_buffer_retaining(). */ char *search_limit; /* Pointer to the character after the last newline in the buffer. */ char saved_char; /* Character after the last newline. */ char *resume; /* Pointer to where to resume search. */ int resume_index = 0; /* Count of characters to ignore after refilling the buffer. */ int line_count = 1; /* Line number. */ int try_backref; /* Set to true if we need to verify the match with a backtracking matcher. */ int initial_line_count; /* Line count at beginning of last search. */ char *match; /* Pointer to the first character after the string matching the regexp. */ int match_count = 0; /* Count of matching lines. */ char *matching_line; /* Pointer to first character of the matching line, or of the first line of context to print if context is turned on. */ char *real_matching_line; /* Pointer to the first character of the real matching line. */ char *next_line; /* Pointer to first character of the line following the matching line. */ int pending_lines = 0; /* Lines of context left over from last match that we have to print. */ static first_match = 1; /* True when nothing has been printed. */ int i; char *tmp; char *execute(); printed_limit_fake = 0; while (fill_buffer_retaining(retain) > 0) { /* Find the last newline in the buffer. */ search_limit = buffer + bufbytes; while (search_limit > buffer && search_limit[-1] != '\n') --search_limit; if (search_limit == buffer) { retain = bufbytes; continue; } /* Save the character after the last newline so regexecute can write its own sentinel newline. */ saved_char = *search_limit; /* Search the buffer for a match. */ printed_limit = buffer; resume = buffer + resume_index; initial_line_count = line_count; while (match = execute(®, resume, search_limit, 0, &line_count, &try_backref)) { ++match_count; /* Find the beginning of the matching line. */ matching_line = match; while (matching_line > resume && matching_line[-1] != '\n') --matching_line; real_matching_line = matching_line; /* Find the beginning of the next line. */ next_line = match; while (next_line < search_limit && *next_line++ != '\n') ; /* If a potential backreference is indicated, try it out with a backtracking matcher to make sure the line is a match. */ if (try_backref && re_search(®ex, matching_line, next_line - matching_line - 1, 0, next_line - matching_line - 1, NULL) < 0) { resume = next_line; if (resume == search_limit) break; else continue; } /* Print leftover lines from last time. If nonmatching_lines is turned on, print these as if they were matching lines. */ while (resume < matching_line && pending_lines) { resume += print_line(resume, initial_line_count++, nonmatching_lines); --pending_lines; } /* Print out the matching or nonmatching lines as necessary. */ if (! nonmatching_lines) { /* Back up over leading context if necessary. */ for (i = leading_context; matching_line > printed_limit && i; --i) { while (matching_line > printed_limit && (--matching_line)[-1] != '\n') ; --line_count; } /* If context is enabled, we may have to print a separator. */ if ((leading_context || trailing_context) && !silent && !first_match && (printed_limit_fake || matching_line > printed_limit)) printf("----------\n"); first_match = 0; /* Print the matching line and its leading context. */ while (matching_line < real_matching_line) matching_line += print_line(matching_line, line_count++, 0); matching_line += print_line(matching_line, line_count++, 1); /* If there's trailing context, leave some lines pending until next time. */ pending_lines = trailing_context; } else if (matching_line > resume) { char *real_resume = resume; /* Back up over leading context if necessary. */ for (i = leading_context; resume > printed_limit && i; --i) { while (resume > printed_limit && (--resume)[-1] != '\n') ; --initial_line_count; } /* If context is enabled, we may have to print a separator. */ if ((leading_context || trailing_context) && !silent && !first_match && (printed_limit_fake || resume > printed_limit)) printf("----------\n"); first_match = 0; /* Print out the presumably matching leading context. */ while (resume < real_resume) resume += print_line(resume, initial_line_count++, 0); /* Print out the nonmatching lines prior to the matching line. */ while (resume < matching_line) resume += print_line(resume, initial_line_count++, 1); /* Deal with trailing context. */ if (trailing_context) { print_line(matching_line, line_count, 0); pending_lines = trailing_context - 1; } /* Count the current line. */ ++line_count; } else { /* The line immediately after a matching line has to be printed because it was pending. */ if (pen
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:Grep ƒ:grep.c
+++++ Continued from previous card +++++
ding_lines > 0) { --pending_lines; print_line(matching_line, line_count, 0); } ++line_count; } /* Resume searching at the beginning of the next line. */ initial_line_count = line_count; resume = next_line; if (resume == search_limit) break; } /* Restore the saved character. */ *search_limit = saved_char; if (! nonmatching_lines) { while (resume < search_limit && pending_lines) { resume += print_line(resume, initial_line_count++, 0); --pending_lines; } } else if (search_limit > resume) { char *initial_resume = resume; /* Back up over leading context if necessary. */ for (i = leading_context; resume > printed_limit && i; --i) { while (resume > printed_limit && (--resume)[-1] != '\n') ; --initial_line_count; } /* If context is enabled, we may have to print a separator. */ if ((leading_context || trailing_context) && !silent && !first_match && (printed_limit_fake || resume > printed_limit)) printf("----------\n"); first_match = 0; /* Print out all the nonmatching lines up to the search limit. */ while (resume < initial_resume) resume += print_line(resume, initial_line_count++, 0); while (resume < search_limit) resume += print_line(resume, initial_line_count++, 1); pending_lines = trailing_context; resume_index = 0; retain = bufbytes - (search_limit - buffer); continue; } /* Save the trailing end of the buffer for possible use as leading context in the future. */ i = leading_context; tmp = search_limit; while (tmp > printed_limit && i--) while (tmp > printed_limit && (--tmp)[-1] != '\n') ; resume_index = search_limit - tmp; retain = bufbytes - (tmp - buffer); if (tmp > printed_limit) printed_limit_fake = 1; } return nonmatching_lines ? line_count - match_count : match_count;}voidusage_and_die(){ fprintf(stderr,"#usage: %s [-CVbchilnsvwx] [-<num>] [-AB <num>] [-f file] [-e] expr [files]\n", prog); exit(ERROR);}static char version[] = "GNU e?grep, version 1.3";main(argc, argv) int argc; char **argv;{ int c; int ignore_case = 0; /* Compile the regexp to ignore case. */ char *the_regexp = 0; /* The regular expression. */ int regexp_len; /* Length of the regular expression. */ char *regexp_file = 0; /* File containing parallel regexps. */ int count_lines = 0; /* Display only a count of matching lines. */ int list_files = 0; /* Display only the names of matching files. */ int whole_word = 0; /* Insist that the regexp match a word only. */ int whole_line = 0; /* Insist on matching only whole lines. */ int line_count = 0; /* Count of matching lines for a file. */ int matches_found = 0; /* True if matches were found. */ char *regex_errmesg; /* Error message from regex routines. */ char translate[_NOTCHAR]; /* Translate table for case conversion (needed by the backtracking matcher). */ if (prog = strrchr(argv[0], '/')) ++prog; else prog = argv[0]; opterr = 0; while ((c = getopt(argc, argv, "0123456789A:B:CZbce:f:hilnsvwx")) != EOF) switch (c) { case '?': usage_and_die(); break; case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': trailing_context = 10 * trailing_context + c - '0'; leading_context = 10 * leading_context + c - '0'; break; case 'A': if (! sscanf(optarg, "%d", &trailing_context) || trailing_context < 0) usage_and_die(); break; case 'B': if (! sscanf(optarg, "%d", &leading_context) || leading_context < 0) usage_and_die(); break; case 'C': trailing_context = leading_context = 2; break; case 'Z': fprintf(stderr, "%s\n", version); break; case 'b': byte_count = 1; break; case 'c': count_lines = 1; silent = 1; break; case 'e': /* It doesn't make sense to mix -f and -e. */ if (regexp_file) usage_and_die(); the_regexp = optarg; break; case 'f': /* It doesn't make sense to mix -f and -e. */ if (the_regexp) usage_and_die(); regexp_file = optarg; break; case 'h': no_filenames = 1; break; case 'i': ignore_case = 1; for (c = 0; c < _NOTCHAR; ++c) if (isupper(c)) translate[c] = tolower(c); else translate[c] = c; regex.translate = translate; break; case 'l': list_files = 1; silent = 1; break; case 'n': line_numbers = 1; break; case 's': silent = 1; break; case 'v': nonmatching_lines = 1; break; case 'w': whole_word = 1; break; case 'x': whole_line = 1; break; default: /* This can't happen. */ fprintf(stderr, "%s: getopt(3) let one by!\n", prog); usage_and_die(); break; } /* Set the syntax depending on whether we are EGREP or not. */#ifdef EGREP regsyntax(RE_SYNTAX_EGREP, ignore_case); re_set_syntax(RE_SYNTAX_EGREP);#else regsyntax(RE_SYNTAX_GREP, ignore_case); re_set_syntax(RE_SYNTAX_GREP);#endif /* Compile the regexp according to all the options. */ if (regexp_file) { FILE *fp = fopen(regexp_file, "r"); int len = 256; int i = 0; if (! fp) { fprintf(stderr, "%s: %s: %s\n", prog, regexp_file, sys_errlist[errno]); exit(ERROR); } the_regexp = malloc(len); while ((c = getc(fp)) != EOF) { the_regexp[i++] = c; if (i == len) the_regexp = realloc(the_regexp, len *= 2); } fclose(fp); /* Nuke the concluding newline so we won't match the empty string. */ if (i > 0 && the_regexp[i - 1] == '\n') --i; regexp_len = i; } else if (! the_regexp) { if (optind >= argc) usage_and_die(); the_regexp = argv[optind++]; regexp_len = strlen(the_regexp); } else regexp_len = strlen(the_regexp); if (whole_word || whole_line) { char *n = malloc(regexp_len + 8); int i = 0; if (whole_line) n[i++] = '^'; else n[i++] = '\\', n[i++] = '<'; if (*prog != 'e') n[i++] = '\\'; n[i++] = '('; memcpy(n + i, the_regexp, regexp_len); i += regexp_len; if (*prog != 'e') n[i++] = '\\'; n[i++] = ')'; if (whole_line) n[i++] = '$'; else n[i++] = '\\', n[i++] = '>'; the_regexp = n; regexp_len = i; } regcompile(the_regexp, regexp_len, ®, 1); if (regex_errmesg = re_compile_pattern(the_regexp, regexp_len, ®ex)) regerror(regex_errmesg); /* Find the longest metacharacter-free string which must occur in the regexpr, before short-circuiting regexecute() with Boyer-Moore-Gosper. (Conjecture: The problem in general is NP-complete.) If there is no such string (like for many alternations), then default to full automaton search. regmust() code and heuristics [see dfa.c] courtesy Arthur David Olson. */ if (line_numbers == 0 && nonmatching_lines == 0) { if (reg.mustn == 0 || reg.mustn == MUST_MAX || strchr(reg.must, '\0') != reg.must + reg.mustn) bmgexec = 0;lse { reg.must[reg.mustn] = '\0'; if (getenv("MUSTDEBUG") != NULL) (void) printf("must have: \"%s\"\n", reg.must); bmg_setup(reg.must, ignore_case); bmgexec = 1; } } if (argc - optind < 2) no_filenames = 1; initialize_buffer(); if (argc > optind) while (optind < argc) { bufprev = eof = 0; filename = argv[optind++]; fd = open(filename, 0, 0); if (fd < 0) { fprintf(stderr, "%s: %s: %s\n", prog, filename, sys_errlist[errno]); error = 1; continue; } if (line_count = grep()) matches_found = 1; close(fd); if (count_lines) if (!no_filenames) printf("%s:%d\n", filename, line_count); else printf("%d\n", line_count); else if (list_files && line_count) printf("%s\n", filename); } else { if (line_count = grep()) matches_found = 1; if (count_lines) printf("%d\n", line_count); else if (list_files && line_count) printf("<stdin>\n"); } if (error) exit(ERROR); if (matches_found) exit(MATCHES_FOUND); exit(NO_MATCHES_FOUND);}/* Needed by the regexp routines. This could be fancier, especially when dealing with parallel regexps in files. */voidregerror(s) const char *s;{ fprintf(stderr, "%s: %s\n", prog, s); exit(ERROR);}/* bmg_setup() and bmg_search() adapted from: Boyer/Moore/Gosper-assisted 'egrep' search, with delta0 table as in original paper (CACM, October, 1977). No delta1 or delta2. According to experiment (Horspool, Soft. Prac. Exp., 1982), delta2 is of minimal practical value. However, to improve for worst case input, integrating the improved Galil strategies (Apostolico/Giancarlo, Siam. J. Comput., February 1986) deserves consideration. James A. Woods Copyleft (C) 1986, 1988 NASA Ames Research Center*/char *execute(r, begin, end, newline, count, try_backref) struct regexp *r; char *begin; char *end; int newline; int *count; int *try_backref;{ register char *p, *s; char *match; char *start = begin; char save; /* regexecute() sentinel */ int len; char *bmg_search(); if (!bmgexec) /* full automaton search */ return(regexecute(r, begin, end, newline, count, try_backref)); else { len = end - begin; while ((match = bmg_search((unsigned char *) start, len)) != NULL) { p = match; /* narrow search range to submatch line */ while (p > begin && *p != '\n') p--; s = match; while (s < end && *s != '\n') s++; s++; save = *s; *s = '\0'; match = regexecute(r, p, s, newline, count, try_backref); *s = save; if (match != NULL) return((char *) match); else { start = s; len = end - start; } } return(NULL); }}#include <ctype.h>int delta0[256];unsigned char cmap[256]; /* (un)folded characters */unsigned char pattern[5000];int patlen;char *bmg_search(buffer, buflen) unsigned char *buffer; int buflen;{ register unsigned char *k, *strend, *s, *buflim; register int t; int j; if (patlen > buflen) return NULL; buflim = buffer + buflen; if (buflen > patlen * 4) strend = buflim - patlen * 4; else strend = buffer; s = buffer; k = buffer + patlen - 1; for (;;) { /* The dreaded inner loop, revisited. */ while (k < strend && (t = delta0[*k])) { k += t; k += delta0[*k]; k += delta0[*k]; } while (k < buflim && delta0[*k]) ++k; if (k == buflim) break; j = patlen - 1; s = k; while (cmap[*--s] == pattern[--j]) ; /* delta-less shortcut for literati, but short shrift for genetic engineers. */ if (j >= 0) k++; else /* submatch */ return ((char *)k); } return(NULL);}bmg_setup(pat, folded) /* compute "boyer-moore" delta table */ char *pat; int folded;{ /* ... HAKMEM lives ... */ int j; patlen = strlen(pat); if (folded) /* fold case while saving pattern */ for (j = 0; j < patlen; j++) pattern[j] = (isupper((int) pat[j]) ? (char) tolower((int) pat[j]) : pat[j]); else memcpy(pattern, pat, patlen); for (j = 0; j < 256; j++) { delta0[j] = patlen; cmap[j] = (char) j; /* could be done at compile time */ } for (j = 0; j < patlen - 1; j++) delta0[pattern[j]] = patlen - j - 1; delta0[pattern[patlen - 1]] = 0; if (folded) { for (j = 0; j < patlen - 1; j++) if (islower((int) pattern[j])) delta0[toupper((int) pattern[j])] = patlen - j - 1; if (islower((int) pattern[patlen - 1])) delta0[toupper((int) pattern[patlen - 1])] = 0; for (j = 'A'; j <= 'Z'; j++) cmap[j] = (char) tolower((int) j); }}#ifndef USG/* (groan) compatibility */char *strchr(s, c) char *s;{ return index(s, c);}char *strrchr(s, c) char *s;{ return rindex(s, c);}char *memcpy(d, s, n) char *d, *s;{ return bcopy(s, d, n);}#elsechar *index(s, c) char *s;{ return strchr(s, c);}char *bcopy(s, d, n) char *s, *d;{ return memcpy(d, s, n);}char *bzero(s, n) char *s;{ return memset(s, 0, n);}bcmp(s, t, n) char *s, *t;{ return memcmp(s, t, n);}#endif :MPW:MPW Tools:Tools with Source:Grep ƒ:grep.make
.TH GREP 1 "1988 December 13" "GNU Project".UC 4.SH NAMEgrep, egrep \- print lines matching a regular expression.SH SYNOPSIS.B grep[.B \-CVbchilnsvwx] [.BI \- num] [.B \-AB.I num] [ [.B \-e].I expr|.B \-f.I file] [.I "files ..."].SH DESCRIPTION.I Grepsearches the files listed in the arguments (or standardinput if no files are given) for all lines that contain a match forthe given.IR expr .If any lines match, they are printed..PPAlso, if any matches were found,.I grepwill exit with a status of 0, but if no matches were found it will exitwith a status of 1. This is useful for building shell scripts thatuse.I grepas a condition for, for example, the.I ifstatement..PPWhen invoked as.I egrepthe syntax of the.I expris slightly different; See below..br.SH "REGULAR EXPRESSIONS".RS 2.5i.ta 1i; 2i.sp.ti -2.0i(grep) (egrep) (explanation).sp.ti -2.0i\fIc\fP \fIc\fP a single (non-meta) character matches itself..sp.ti -2.0i\&. . matches any single character except newline..sp.ti -2.0i\\? ? postfix operator; preceeding item is optional..sp.ti -2.0i\(** \(** postfix operator; preceeding item 0 ormore times..sp.ti -2.0i\\+ + postfix operator; preceeding item 1 ormore times..sp.ti -2.0i\\| | infix operator; matches eitherargument..sp.ti -2.0i^ ^ matches the empty string at the beginning of a line..sp.ti -2.0i$ $ matches the ring at the end of a line..sp.ti -2.0i\\< \\< matches the empty string at the beginning of a word..sp.ti -2.0i\\> \\> matches the empty string at the end of a word..sp.ti -2.0i[\fIchars\fP] [\fIchars\fP] match any character in the given class; if thefirst character after [ is ^, match any characternot in the given class; a range of characters maybe specified by \fIfirst\-last\fP; for example, \\W(below) is equivalent to the class [^A\-Za\-z0\-9].sp.ti -2.0i\\( \\) ( ) parentheses are used to override operator precedence..sp.ti -2.0i\\\fIdigit\fP \\\fIdigit\fP \\\fIn\fP matches a repeat of the textmatched earlier in the regexp by the subexpression inside the nthopening parenthesis..sp.ti -2.0i\\ \\ any special character may be precededby a backslash to match it literally..sp.ti -2.0i(the following are for compatibility with GNU Emacs).sp.ti -2.0i\\b \\b matches the empty string at the edge of a word..sp.ti -2.0i\\B \\B matches the empty string if not at the edge of a word..sp.ti -2.0i\\w \\w matches word-constituent characters (letters & digits)..sp.ti -2.0i\\W \\W matches characters that are not word-constituent..RE.PPOperator precedence is (highest to lowest) ?, \(**, and +, concatenation,and finally |. All other constructs are syntactically identical tonormal characters. For the truly interested, the file dfa.c describes(and implements) the exact grammar understood by the parser..SH OPTIONS.TP.BI \-A " num"print <num> lines of context after every matching line.TP.BI \-B " num"print.I numlines of context before every matching line.TP.B \-Cprint 2 lines of context on each side of every match.TP.BI \- numprint.I numlines of context on each side of every match.TP.B \-Vprint the version number on the diagnostic output.TP.B \-bprint every match preceded by its byte offset.TP.B \-cprint a total count of matching lines only.TP.BI \-e " expr"search for.IR expr ;useful if.I exprbegins with \-.TP.BI \-f " file"search for the expression contained in.I file.TP.B \-hdon't display filenames on matches.TP.B \-iignore case difference when comparing strings.TP.B \-llist files containing matches only.TP.B \-nprint each match preceded by its line number.TP.B \-srun silently producing no output except error messages.TP.B \-vprint only lines that contain no matches for the <expr>.TP.B \-wprint only lines where the match is a complete word.TP.B \-xprint only lines where the match is a whole line.SH "SEE ALSO"emacs(1), ed(1), sh(1),.I "GNU Emacs Manual".SH INCOMPATIBILITIESThe following incompatibilities with UNIX.I grepexist:.PP.RS 0.5iThe context-dependent meaning of \(** is not quite the same (grep only)..PP.B \-bprints a byte offset instead of a block offset..PPThe {\fIm,n\fP} construct of System V grep is not implemented..PP.SH BUGSGNU \fIe?grep\fP has been thoroughly debugged and tested by several peopleover a period of several months; we think it's a reliable beast or wewouldn't distribute it. If by some fluke of the universe you discovera bug, send a detailed description (including options, regularexpressions, and a copy of an input file that can reproduce it) to me,mike@wheaties.ai.mit.edu..PPThere is also a newsgroup, gnu.utils.bug, for reporting FSF utilityprograms' bugs and fixes; but before reporting something as a bug,please try to be sure that it really is a bug, not a misunderstandingor a deliberate feature. Also, include the version number of theutility program you are running in \fIevery\fR bug report that yousend in. Please do not send anything but bug reports to thisnewsgroup..PP.SH AVAILABILITY.PPGNU.I grepis free; anyone may redistribute copies of .I greptoanyone under the terms stated in the GNU General Public License,a copy of which may be found in each copy of .IR "GNU Emacs" .See also the comment at the beginning of the source code file grep.c..PPCopies of GNU.I grepmay sometimes be received packaged with distributions of Unix systems,but it is never included in the scope of any license covering thosesystems. Such inclusion violates the terms on which distributionis permitted. In fact, the primary purpose of the General PublicLicense is to prohibit anyone from attaching any other restrictionsto redistribution of any of the Free Software Foundation programs..SH AUTHORSMike Haertel wrote the deterministic regexp code and the bulkof the program..PPJames A. Woods is responsible for the hybridized search strategyof using Boyer-Moore-Gosper fixed-string search as a filterbefore calling the general regexp matcher..PPArthur David Olson contributed code that finds fixed strings forthe aforementioned BMG search for a large class of regexps..PPRichard Stallman wrote the backtracking regexp matcher that isused for \\\fIdigit\fP backreferences, as well as the getopt thatis provided for 4.2BSD sites. The backtracking matcher wasoriginally written for GNU Emacs..PPD. A. Gwyn wrote the C alloca emulation that is provided soSystem V machines can run this program. (Alloca is used onlyby RMS' backtracking matcher, and then only rarely, so thereis no loss if your machine doesn't have a "real" alloca.).PPScott Anderson and Henry Spencer designed the regression testsused in the "regress" script..PPPaul Placeway wrote the original version of this manual page. :MPW:MPW Tools:Tools with Source:Grep ƒ:grep.man.formatted
GREP(1) UNIX Programmer's Manual GREP(1)NAME grep, egrep - print lines matching a regular expressionSYNOPSIS grep [ -CVbchilnsvwx ] [ -num ] [ -AB num ] [ [ -e ] expr | -f file ] [ files ... ]DESCRIPTION Grep searches the files listed in the arguments (or standard input if no files are given) for all lines that contain a match for the given expr. If any lines match, they are printed. Also, if any matches were found, grep will exit with a status of 0, but if no matches were found it will exit with a status of 1. This is useful for building shell scripts that use grep as a condition for, for example, the if state- ment. When invoked as egrep the syntax of the expr is slightly different; See below.REGULAR EXPRESSIONS (grep) (egrep) (explanation) c c a single (non-meta) character matches itself. . . matches any single character except newline. \? ? postfix operator; preceeding item is optional. * * postfix operator; preceeding item 0 or more times. \+ + postfix operator; preceeding item 1 or more times. \| | infix operator; matches either argument. ^ ^ matches the empty string at the beginning of a line. $ $ matches the empty string at the end of a line. \< \< matches the empty string at the beginning of a word.Printed 3/21/89 1988 December 13 1GREP(1) UNIX Programmer's Manual GREP(1) \> \> matches the empty string at the end of a word. [chars] [chars] match any character in the given class; if the first character after [ is ^, match any character not in the given class; a range of charac- ters may be specified by first-last; for example, \W (below) is equivalent to the class [^A-Za-z0-9] \( \) ( ) parentheses are used to override operator precedence. \digit \digit \n matches a repeat of the text matched earlierregexp by the subexpression inside the nth opening parenthesis. \ \ any special character may be pre- ceded by a backslash to match it literally. (the following are for compatibility with GNU Emacs) \b \b matches the empty string at the edge of a word. \B \B matches the empty string if not at the edge of a word. \w \w matches word-constituent characters (letters & digits). \W \W matches characters that are not word-constituent. Operator precedence is (highest to lowest) ?, *, and +, con- catenation, and finally |. All other constructs are syntac- tically identical to normal characters. For the truly interested, the file dfa.c describes (and implements) the exact grammar understood by the parser.OPTIONS -A num print <num> lines of context after every matching line -B num print num lines of context before every matching line -C print 2 lines of context on each side of every matchPrinted 3/21/89 1988 December 13 2GREP(1) UNIX Programmer's Manual GREP(1) -num print num lines of context on each side of every match -V print the version number on the diagnostic output -b print every match preceded by its byte offset -c print a total count of matching lines only -e expr search for expr; useful if expr begins with - -f file search for the expression contained in file -h don't display filenames on matches -i ignore case difference when comparing strings -l list files containing matches only -n print each match preceded by its line number -s run silently producing no output except error messages -v print only lines that contain no matches for the <expr> -w print only lines where the match is a complete word -x print only lines where the match is a whole lineSEE ALSO emacs(1), ed(1), sh(1), GNU Emacs ManualINCOMPATIBILITIES The following incompatibilities with UNIX grep exist: The context-dependent meaning of * is not quite the same (grep only). -b prints a byte offset instead of a block offset. The {m,n} construct of System V grep is not imple- mented.BUGS GNU e?grep has been thoroughly debugged and tested by several people over a period of several months; we think it's a reliable beast or we wouldn't distribute it. If by some fluke of the universe you discover a bug, send a detailed description (including options, regular expres- sions, and a copy of an input file that can reproduce it) to me, mike@wheaties.ai.mit.edu.Printed 3/21/89 1988 December 13 3GREP(1) UNIX Programmer's Manual GREP(1) There is also a newsgroup, gnu.utils.bug, for reporting FSF utility programs' bugs and fixes; but before reporting some- thing as a bug, please try to be sure that it really is a bug, not a misunderstanding or a deliberate feature. Also, include the version number of the utility program you are running in every bug report that you send in. Please do not send anything but bug reports to this newsgroup.AVAILABILITY GNU grep is free; anyone may redistribute copies of grep to anyone under the terms stated in the GNU General Public License, a copy of which may be found in each copy of GNU Emacs. See also the comment at the beginning of the source code file grep.c. Copies of GNU grep may sometimes be received packaged with distributions of Unix systems, but it is never included in the scope of any license covering those systems. Such inclusion violates the terms on which distribution is per- mitted. In fact, the primary purpose of the General Public License is to prohibit anyone from attaching any other res- trictions to redistribution of any of the Free Software Foundation programs.AUTHORS Mike Haertel wrote the deterministic regexp code and the bulk of the program. James A. Woods is responsible for the hybridized search strategy of using Boyer-Moore-Gosper fixed-string search as a filter before calling the general regexp matcher. Arthur David Olson contributed code that finds fixed strings for the aforementioned BMG search for a large class of regexps. Richard Stallman wrote the backtracking regexp matcher that is used for \digit backreferences, as well as the getopt that is provided for 4.2BSD sites. The backtracking matcher was originally written for GNU Emacs. D. A. Gwyn wrote the C alloca emulation that is provided so System V machines can run this program. (Alloca is used only by RMS' backtracking matcher, and then only rarely, so there is no loss if your machine doesn't have a "real" alloca.) Scott Anderson and Henry Spencer designed the regression tests used in the "regress" script. Paul Placeway wrote the original version of this manual page.Printed 3/21/89 1988 December 13 4 :MPW:MPW Tools:Tools with Source:Grep ƒ:grep.r
## Makefile for GNU e?grep## Add -DUSG for System V.CFLAGS = -O## You may add getopt.o if your C library lacks getopt(); note that# 4.3BSD getopt() is said to be somewhat broken.## Add alloca.o if your machine does not support alloca().#OBJS = dfa.o regex.oGOBJ = grep.oEOBJ = egrep.o# Space provided for machine dependent libraries.LIBS =all: regressregress: egrep grep cd tests; sh regress.shegrep: $(OBJS) $(EOBJ) $(CC) $(CFLAGS) -o egrep $(OBJS) $(EOBJ) $(LIBS)egrep.o: grep.c $(CC) $(CFLAGS) -DEGREP -c grep.c mv grep.o egrep.ogrep: $(OBJS) $(GOBJ) $(CC) $(CFLAGS) -o grep $(OBJS) $(GOBJ) $(LIBS)clean: rm -f grep egrep *.o core tests/core tests/tmp.script tests/khadafy.outdfa.o egrep.o grep.o: dfa.hegrep.o grep.o regex.o: regex.h :MPW:MPW Tools:Tools with Source:Grep ƒ:README
This README documents GNU e?grep version 1.3.Changes needed to the makefile under various perversions of Unix aredescribed therein.If the type "char" is unsigned on your machine, you will have to fixthe definition of the macro SIGN_EXTEND_CHAR() in regex.c. A reasonabledefinition might be: #define SIGN_EXTEND_CHAR(c) ((c)>(char)127?(c)-256:(c))GNU e?grep is provided "as is" with no warranty. The exact termsunder which you may use and (re)distribute this program are detailedin a comment at the top of grep.c.GNU e?grep is based on a fast lazy-state deterministic matcher (abouttwice as fast as stock Unix egrep) hybridized with a Boyer-Moore-Gospersearch for a fixed string that eliminates impossible text from beingconsidered by the full regexp matcher without necessarily having tolook at every character. The result is typically many times fasterthan Unix grep or egrep. (Regular expressions containing backreferencingmay run more slowly, however.)GNU e?grep attempts, as closely as possible, to understand compatiblythe regexp syntaxes of the Unix programs it replaces. The following tabledetails the various special characters understood in both the grep andegrep incarnations:(grep) (egrep) (explanation) . . matches any single character except newline \? ? postfix operator; preceeding item is optional * * postfix operator; preceeding item 0 or more times \+ + postfix operator; preceeding item 1 or more times \| | infix operator; matches either argument ^ ^ matches the empty string at the beginning of a line $ $ matches the empty string at the end of a line \< \< matches the empty string at the beginning of a word \> \> matches the empty string at the end of a word [chars] [chars] match any character in the given class; if the first character after [ is ^, match any character not in the given class; a range of characters may be specified by <first>-<last>; for example, \W (below) is equivalent to the class [^A-Za-z0-9] \( \) ( ) parentheses are used to override operator precedence \<1-9> \<1-9> \<n> matches a repeat of the text matched earlier in the regexp by the subexpression inside the nth opening parenthesis \ \ any special character may be preceded by a backslash to match it literally(the following are for compatibility with GNU Emacs) \b \b matches the empty string at the edge of a word \B \B matches the empty string if not at the edge of a word \w \w matches word-constituent characters (letters & digits) \W \W matches characters that are not word-constituentOperator precedence is (highest to lowest) ?, *, and +, concatenation,and finally |. All other constructs are syntactically identical tonormal characters. For the truly interested, a comment in dfa.c describesthe exact grammar understood by the parser.GNU e?grep understands the following command line options: -A <num> print <num> lines of context after every matching line -B <num> print <num> lines of context before every matching line -C print 2 lines of context on each side of every match -<num> print <num> lines of context on each side -V print the version number on stderr -b print every match preceded by its byte offset -c print a total count of matching lines only -e <expr> search for <expr>; useful if <expr> begins with - -f <file> take <expr> from the given <file> -h don't display filenames on matches -i ignore case difference when comparing strings -l list files containing matches only -n print each match preceded by its line number -s run silently producing no output except error messages -v print only lines that contain no matches for the <expr> -w print only lines where the match is a complete word -x print only lines where the match is a whole lineThe options understood by GNU e?grep are meant to be (nearly) compatiblewith both the BSD and System V versions of grep and egrep.The following incompatibilities with other versions of grep exist: the context-dependent meaning of * is not quite the same (grep only) -b prints a byte offset instead of a block offset the \{m,n\} construct of System V grep is not implementedGNU e?grep has been thoroughly debugged and tested by several peopleover a period of several months; we think it's a reliable beast or wewouldn't distribute it. If by some fluke of the universe you discovera bug, send a detailed description (including options, regularexpressions, and a copy of an input file that can reproduce it) to me,mike@wheaties.ai.mit.edu.GNU e?grep is brought to you by the efforts of several people: Mike Haertel wrote the deterministic regexp code and the bulk of the program. James A. Woods is responsible for the hybridized search strategy of using Boyer-Moore-Gosper fixed-string search as a filter before calling the general regexp matcher. Arthur David Olson contributed code that finds fixed strings for the aforementioned BMG search for a large class of regexps. Richard Stallman wrote the backtracking regexp matcher that is used for \<digit> backreferences, as well as the getopt that is provided for 4.2BSD sites. The backtracking matcher was originally written for GNU Emacs. D. A. Gwyn wrote the C alloca emulation that is provided so System V machines can run this program. (Alloca is used only by RMS' backtracking matcher, and then only rarely, so there is no loss if your machine doesn't have a "real" alloca.) Scott Anderson and Henry Spencer designed the regression tests used in the "regress" script. Paul Placeway wrote the manual page, based on this README.If you are interested in improving this program, you may wish to tryany of the following:1. Make backreferencing \<digit> faster. Right now, backreferencing is handled by calling the Emacs backtracking matcher to verify the partial match. This is slow; if the DFA routines could handle backreferencing themselves a speedup on the order of three to four times might occur in those cases where the backtracking matcher is called to verify nearly every line. Also, some portability problems due to the inclusion of the emacs matcher would be solved because it could then be eliminated. Note that expressions with backreferencing are not true regular expressions, and thus are not equivalent to any DFA. So this is hard.2. There is a bug in the backtracking matcher, regex.c, such that the | operator is not properly commutative. Let x and y be arbitrary regular expressions, and suppose both x and y have matches at some point in the target text. Then the regexp x|y should select the longest of the two matches. With the backtracking matcher, if the first match succeeds it does not even try the second, even though the second may be a longer match. This is obviously of no concern for grep, which does not care exactly where or how long a match is, so long as it knows it is there. On the other hand, the backtracking matcher is used in GNU AWK, wherein its behavior can only be considered a bug.3. Handle POSIX style regexps. I'm not sure if this could be called an improvement; some of the things on regexps in the POSIX draft I have seen are pretty sickening. But it would be useful in the interests of conforming to the standard. :MPW:MPW Tools:Tools with Source:Grep ƒ:README.cray
(Message inbox:135)Date: Mon, 17 Oct 88 16:53:33 PDTTo: mike@wheaties.ai.mit.educc: darin%pioneer@eos.arc.nasa.gov, luzmoor@violet.berkeley.eduFrom: James A. Woods <jaw@eos.arc.nasa.gov>Subject: README.cray for GNU e?grepI just sent this out to comp.unix.cray:-------------------------------------------------------------------From: jaw@eos.UUCP (James A. Woods)Newsgroups: comp.unix.craySubject: GNU e?grep on Cray machinesMessage-ID: <1750@eos.UUCP>Date: 17 Oct 88 23:47:29 GMTOrganization: NASA Ames Research Center, CaliforniaLines: 66# "What comes after silicon? Oh, gallium arsenide, I'd guess. And after that, there's a thing called indium phosphide." -- Seymour Cray, Datamation interview, circa 1980 Now that most Cray software development is done on Crays themselves, thanks to Unix, GNU e?grep should come in handy. Of course, if you'rescanning GENBANK for the Human Genome Project at 10 MB/second (the rawX/MP Unix I/O rate), you really do need the speed. Sample, from one of the Ames Cray 2 machines: stokes> time ./egrep astrian web2 # GNU egrep alabastrian Lancastrian Zoroastrian Zoroastrianism 0.5980u 0.0772s 0:01 35% stokes> time /usr/bin/egrep astrian web2 # ATT egrep alabastrian Lancastrian Zoroastrian Zoroastrianism 7.6765u 0.1373s 0:15 49%(web2 is a 2.4 MB wordlist, standard on BSD Unix.) To bring up GNU E?GREP, ftp Mike Haertel's version 1.1 package from'prep.ai.mit.edu' or 'ames.arc.nasa.gov'. Mention -DUSG in the Makefile,and specify #define SIGN_EXTEND_CHAR(c) ((c)>(char)127?(c)-256:(c))in regex.c. [Cray characters, like MIPS chars, are unsigned, but thecompiler won't allow ... #define SIGN_EXTEND_CHAR(c) ((signed char) (c))] However, at least on the Cray 2, there's a compiler bug involving theincrement operator in complex expressions, which requires the followingmodification (also in regex.c):change m->elems[m->nelem++].constraint |= s2->elems[j++].constraint;to m->elems[m->nelem].constraint |= s2->elems[j].constraint; m->nelem++; j++;Thanks go to Darin Okuyama of NASA ARC for providing this workaround.-- James A. Woods (ames!jaw) NASA Ames Research CenterP.S. Though Crays are not at their best pushing bytes, the timing differenceis even more exaggerated with heavier regexpr processing, to wit: time ./egrep -i 'as.*Trian' web2 ... 0.7677u 0.0769s 0:01 44%vs. time /usr/bin/egrep -i 'as.*Trian' web2 ... 16.1327u 0.1379s 0:32 49%which is a mite unfair given a known System 5 egrep -i gaffe. You getextra credit for vectorizing the inner loop of the Boyer/Moore/Gospercode, though changing all chars to ints might help also. :MPW:MPW Tools:Tools with Source:Grep ƒ:README.mpw
This port of GNU e?grep 1.3 to Apple Computer's MPW was done, despite the objectionsof rms to Apple systems, by David D Zuhn.The filename and line number displays were changed to work with MPW's File and Linecommands. Just select a line and hit 'Enter', and that line will be brought to thefront and highlighted (just like compiler errors).MPW C 3.0 was used, with the MPW 3.0 libraries. Thanks to Earle Horton of Dartmouth University for alloca.a. Much cleaner thanthe portable alloca.c provided in the source code. David D ZuhnComputer Science DepartmentUniversity of Minnesota - Twin Citieszuhn@umn-cs.cs.umn.edu :MPW:MPW Tools:Tools with Source:Grep ƒ:README.sunos4
Date: Fri, 24 Feb 89 15:36:40 -0600To: mike@wheaties.ai.mit.eduFrom: Dave Cohrs <dave@cs.wisc.edu>Subject: bug + fix in gnu grep 1.2 (from prep.ai.mit.edu)I tried installing the GNU grep 1.2 on a Sun4 running 4.0.1 and"Spencer test #36" failed. After some experimenting, I found andfixed the bug. Well, actually, the bug in the the C compiler, butI managed a workaround.Description:The Sun4 4.0.1 C compiler with -O doesn't generate the correct forstatements of the form if("string") x; else y;To be exact, "y;" gets executed, while "x;" should. This causes the#define FETCH() to fail for test #36.Fix:In an #ifdef sparc in dfa.c, I made two versions of FETCH, FETCH0() andthe regular FETCH(). The former takes only one argument, the latterexpects its 2nd argument to contain a non-nil string. This removesthe need to test the constant strings, and the compiler bug isn'texercised. I then changed the one instance of FETCH() with a nilsecond argument to be FETCH0() instead.dave cohrs===================================================================RCS file: RCS/dfa.c,vretrieving revision 1.1diff -c -r1.1 dfa.c*** /tmp/,RCSt1a05930 Fri Feb 24 15:32:33 1989--- dfa.c Fri Feb 24 15:23:34 1989****************** 285,293 ****--- 285,315 ---- is turned off). */ /* Note that characters become unsigned here. */+ #ifdef sparc+ /*+ * Sun4 4.0.1 C compiler can't compare constant strings correctly.+ * e.g. if("test") { x; } else { y; }+ * the compiler will not generate code to execute { x; }, but+ * executes { y; } instead.+ */+ #define FETCH0(c) \+ { \+ if (! lexleft) \+ return _END; \+ (c) = (unsigned char) *lexptr++; \+ --lexleft; \+ } #define FETCH(c, eoferr) \ { \ if (! lexleft) \+ regerror(eoferr); \+ (c) = (unsigned char) *lexptr++; \+ --lexleft; \+ }+ #else+ #define FETCH(c, eoferr) \+ { \+ if (! lexleft) \ if (eoferr) \ regerror(eoferr); \ else \****************** 295,300 ****--- 317,323 ---- (c) = (unsigned char) *lexptr++; \ --lexleft; \ }+ #endif sparc static _token lex()****************** 303,309 ****--- 326,336 ---- int invert; _charset cset; + #ifdef sparc+ FETCH0(c);+ #else FETCH(c, (char *) 0);+ #endif sparc switch (c) { case '^': :MPW:MPW Tools:Tools with Source:Grep ƒ:regex.c
/* Extended regular expression matching and search library. Copyright (C) 1985, 1989 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. In other words, you are welcome to use, share and improve this program. You are forbidden to forbid anyone else to use, share and improve what you give them. Help stamp out software-hoarding! *//* To test, compile with -Dtest. This Dtestable feature turns this into a self-contained program which reads a pattern, describes how it compiles, then reads a string and searches for it. */#ifdef emacs/* The `emacs' switch turns on certain special matching commands that make sense only in emacs. */#include "config.h"#include "lisp.h"#include "buffer.h"#include "syntax.h"#else /* not emacs */#ifdef USG#define bcopy(s,d,n) memcpy((d),(s),(n))#define bcmp(s1,s2,n) memcmp((s1),(s2),(n))#define bzero(s,n) memset((s),0,(n))#endif/* Make alloca work the best possible way. */#ifdef __GNUC__#define alloca __builtin_alloca#else#ifdef sparc#include <alloca.h>#endif#endif/* * Define the syntax stuff, so we can do the \<...\> things. */#ifndef Sword /* must be non-zero in some of the tests below... */#define Sword 1#endif#define SYNTAX(c) re_syntax_table[c]#ifdef SYNTAX_TABLEchar *re_syntax_table;#elsestatic char re_syntax_table[256];static voidinit_syntax_once (){ register int c; static int done = 0; if (done) return; bzero (re_syntax_table, sizeof re_syntax_table); for (c = 'a'; c <= 'z'; c++) re_syntax_table[c] = Sword; for (c = 'A'; c <= 'Z'; c++) re_syntax_table[c] = Sword; for (c = '0'; c <= '9'; c++) re_syntax_table[c] = Sword; done = 1;}#endif /* SYNTAX_TABLE */#endif /* not emacs */#include "regex.h"/* Number of failure points to allocate space for initially, when matching. If this number is exceeded, more space is allocated, so it is not a hard limit. */#ifndef NFAILURES#define NFAILURES 80#endif /* NFAILURES *//* width of a byte in bits */#define BYTEWIDTH 8#ifndef SIGN_EXTEND_CHAR#define SIGN_EXTEND_CHAR(x) (x)#endif static int obscure_syntax = 0;/* Specify the precise syntax of regexp for compilation. This provides for compatibility for various utilities which historically have different, incompatible syntaxes. The argument SYNTAX is a bit-mask containing the two bits RE_NO_BK_PARENS and RE_NO_BK_VBAR. */intre_set_syntax (syntax){ int ret; retre_syntax; obscure_syntax = syntax; return ret;} /* re_compile_pattern takes a regular-expression string and converts it into a buffer full of byte commands for matching. PATTERN is the address of the pattern string SIZE is the length of it. BUFP is a struct re_pattern_buffer * which points to the info on where to store the byte commands. This structure contains a char * which points to the actual space, which should have been obtained with malloc. re_compile_pattern may use realloc to grow the buffer space. The number of bytes of commands can be found out by looking in the struct re_pattern_buffer that bufp pointed to, after re_compile_pattern returns.*/#define PATPUSH(ch) (*b++ = (char) (ch))#define PATFETCH(c) \ {if (p == pend) goto end_of_pattern; \ c = * (unsigned char *) p++; \ if (translate) c = translate[c]; }#define PATFETCH_RAW(c) \ {if (p == pend) goto end_of_pattern; \ c = * (unsigned char *) p++; }#define PATUNFETCH p--#define EXTEND_BUFFER \ { char *old_buffer = bufp->buffer; \ if (bufp->allocated == (1<<16)) goto too_big; \ bufp->allocated *= 2; \ if (bufp->allocated > (1<<16)) bufp->allocated = (1<<16); \ if (!(bufp->buffer = (char *) realloc (bufp->buffer, bufp->allocated))) \ goto memory_exhausted; \ c = bufp->buffer - old_buffer; \ b += c; \ if (fixup_jump) \ fixup_jump += c; \ if (laststart) \ laststart += c; \ begalt += c; \ if (pending_exact) \ pending_exact += c; \ }static int store_jump (), insert_jump ();char *re_compile_pattern (pattern, size, bufp) char *pattern; int size; struct re_pattern_buffer *bufp;{ register char *b = bufp->buffer; register char *p = pattern; char *pend = pattern + size; register unsigned c, c1; char *p1; unsigned char *translate = (unsigned char *) bufp->translate; /* address of the count-byte of the most recently inserted "exactn" command. This makes it possible to tell whether a new exact-match character can be added to that command or requires a new "exactn" command. */ char *pending_exact = 0; /* address of the place where a forward-jump should go to the end of the containing expression. Each alternative of an "or", except the last, ends with a forward-jump of this sort. */ char *fixup_jump = 0; /* address of start of the most recently finished expression. This tells postfix * where to find the start of its operand. */ char *laststart = 0; /* In processing a repeat, 1 means zero matches is allowed */ char zero_times_ok; /* In processing a repeat, 1 means many matches is allowed */ char many_times_ok; /* address of beginning of regexp, or inside of last \( */ char *begalt = b; /* Stack of information saved by \( and restored by \). Four stack elements are pushed by each \(: First, the value of b. Second, the value of fixup_jump. Third, the value of regnum. Fourth, the value of begalt. */ int stackb[40]; int *stackp = stackb; int *stacke = stackb + 40; int *stackt; /* Counts \('s as they are encountered. Remembered for the matching \), where it becomes the "register number" to put in the stop_memory command */ int regnum = 1; bufp->fastmap_accurate = 0;#ifndef emacs#ifndef SYNTAX_TABLE /* * Initialize the syntax table. */ init_syntax_once();#endif#endif if (bufp->allocated == 0) { bufp->allocated = 28; if (bufp->buffer) /* EXTEND_BUFFER loses when bufp->allocated is 0 */ bufp->buffer = (char *) realloc (bufp->buffer, 28); else /* Caller did not allocate a buffer. Do it for him */ bufp->buffer = (char *) malloc (28); if (!bufp->buffer) goto memory_exhausted; begalt = b = bufp->buffer; } while (p != pend) { if (b - bufp->buffer > bufp->allocated - 10) /* Note that EXTEND_BUFFER clobbers c */ EXTEND_BUFFER; PATFETCH (c); switch (c) { case '$': if (obscure_syntax & RE_TIGHT_VBAR) { if (! (obscure_syntax & RE_CONTEXT_INDEP_OPS) && p != pend) goto normal_char; /* Make operand of last vbar end before this `$'. */ if (fixup_jump) store_jump (fixup_jump, jump, b); fixup_jump = 0; PATPUSH (endline); break; } /* $ means succeed if at end of line, but only in special contexts. If randomly in the middle of a pattern, it is a normal character. */ if (p == pend || *p == '\n' || (obscure_syntax & RE_CONTEXT_INDEP_OPS) || (obscure_syntax & RE_NO_BK_PARENS ? *p == ')' : *p == '\\' && p[1] == ')') || (obscure_syntax & RE_NO_BK_VBAR ? *p == '|' : *p == '\\' && p[1] == '|')) { PATPUSH (endline); break; } goto normal_char; case '^': /* ^ means succeed if at beg of line, but only if no preceding pattern. */ if (laststart && p[-2] != '\n' && ! (obscure_syntax & RE_CONTEXT_INDEP_OPS)) goto normal_char; if (obscure_syntax & RE_TIGHT_VBAR) { if (p != pattern + 1 && ! (obscure_syntax & RE_CONTEXT_INDEP_OPS)) goto normal_char; PATPUSH (begline); begalt = b; } else PATPUSH (begline); break; case '+': case '?': if (obscure_syntax & RE_BK_PLUS_QM) goto normal_char; handle_plus: case '*': /* If there is no previous pattern, char not special. */ if (!laststart && ! (obscure_syntax & RE_CONTEXT_INDEP_OPS)) goto normal_char; /* If there is a sequence of repetition chars, collapse it down to equivalent to just one. */ zero_times_ok = 0; many_times_ok = 0; while (1) { zero_times_ok |= c != '+'; many_times_ok |= c != '?'; if (p == pend) break; PATFETCH (c); if (c == '*') ; else if (!(obscure_syntax & RE_BK_PLUS_QM) && (c == '+' || c == '?')) ; else if ((obscure_syntax & RE_BK_PLUS_QM) && c == '\\') { int c1; PATFETCH (c1); if (!(c1 == '+' || c1 == '?')) { PATUNFETCH; PATUNFETCH; break; } c = c1; } else { PATUNFETCH; break; } } /* Star, etc. applied to an empty pattern is equivalent to an empty pattern. */ if (!laststart) break; /* Now we know whether 0 matches is allowed, and whether 2 or more matches is allowed. */ if (many_times_ok) { /* If more than one repetition is allowed, put in a backward jump at the end. */ store_jump (b, maybe_finalize_jump, laststart - 3); b += 3; } insert_jump (on_failure_jump, laststart, b + 3, b); pending_exact = 0; b += 3; if (!zero_times_ok) { /* At least one repetition required: insert before the loop a skip over the initial on-failure-jump instruction */ insert_jump (dummy_failure_jump, laststart, laststart + 6, b); b += 3; } break; case '.': laststart = b; PATPUSH (anychar); break; case '[': while (b - bufp->buffer > bufp->allocated - 3 - (1 << BYTEWIDTH) / BYTEWIDTH) /* Note that EXTEND_BUFFER clobbers c */ EXTEND_BUFFER; laststart = b; if (*p == '^') PATPUSH (charset_not), p++; else PATPUSH (charset); p1 = p; PATPUSH ((1 << BYTEWIDTH) / BYTEWIDTH); /* Clear the whole map */ bzero (b, (1 << BYTEWIDTH) / BYTEWIDTH); /* Read in characters and ranges, setting map bits */ while (1) { PATFETCH (c); if (c == ']' && p != p1 + 1) break; if (*p == '-' && p[1] != ']') { PATFETCH (c1); PATFETCH (c1); while (c <= c1) b[c / BYTEWIDTH] |= 1 << (c % BYTEWIDTH), c++; } else { b[c / BYTEWIDTH] |= 1 << (c % BYTEWIDTH); } } /* Discard any bitmap bytes that are all 0 at the end of the map. Decrement the map-length byte too. */ while ((int) b[-1] > 0 && b[b[-1] - 1] == 0) b[-1]--; b += b[-1]; break; case '(': if (! (obscure_syntax & RE_NO_BK_PARENS)) goto normal_char; else goto handle_open; case ')': if (! (obscure_syntax & RE_NO_BK_PARENS)) goto normal_char; else goto handle_close; case '\n': if (! (obscure_syntax & RE_NEWLINE_OR)) goto normal_char; else goto handle_bar; case '|': if (! (obscure_syntax & RE_NO_BK_VBAR)) goto normal_char; else goto handle_bar; case '\\': if (p == pend) goto invalid_pattern; PATFETCH_RAW (c); switch (c) { case '(': if (obscure_syntax & RE_NO_BK_PARENS) goto normal_backsl; handle_open: if (stackp == stacke) goto nesting_too_deep; if (regnum < RE_NREGS) { PATPUSH (start_memory); PATPUSH (regnum); } *stackp++ = b - bufp->buffer; *stackp++ = fixup_jump ? fixup_jump - bufp->buffer + 1 : 0; *stackp++ = regnum++; *stackp++ = begalt - bufp->buffer; fixup_jump = 0; laststart = 0; begalt = b; break; case ')': if (obscure_syntax & RE_NO_BK_PARENS) goto normal_backsl; handle_close: if (stackp == stackb) goto unmatched_close; begalt = *--stackp + bufp->buffer; if (fixup_jump) store_jump (fixup_jump, jump, b); if (stackp[-1] < RE_NREGS) { PATPUSH (stop_memory); PATPUSH (stackp[-1]); } stackp -= 2; fixup_jump = 0; if (*stackp) fixup_jump = *stackp + bufp->buffer - 1; laststart = *--stackp + bufp->buffer; break; case '|': if (obscure_syntax & RE_NO_BK_VBAR) goto normal_backsl; handle_bar: insert_jump (on_failure_jump, begalt, b + 6, b); pending_exact = 0; b += 3; if (fixup_jump) store_jump (fixup_jump, jump, b); fixup_jump = b; b += 3; laststart = 0; begalt = b; break;#ifdef emacs case '=': PATPUSH (at_dot); break; case 's': laststart = b; PATPUSH (syntaxspec); PATFETCH (c); PATPUSH (syntax_spec_code[c]); break; case 'S': laststart = b; PATPUSH (notsyntaxspec); PATFETCH (c); PATPUSH (syntax_spec_code[c]); break;#endif /* emacs */ case 'w': laststart = b; PATPUSH (wordchar); break; case 'W': laststart = b; PATPUSH (notwordchar); break; case '<': PATPUSH (wordbeg); break; case '>': PATPUSH (wordend); break; case 'b': PATPUSH (wordbound); break; case 'B': PATPUSH (notwordbound); break; case '`': PATPUSH (begbuf); break; case '\'': PATPUSH (endbuf); break; case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': c1 = c - '0'; if (c1 >= regnum) goto normal_char; for (stackt = stackp - 2; stackt > stackb; stackt -= 4) if (*stackt == c1) goto normal_char; laststart = b; PATPUSH (duplicate); PATPUSH (c1); break; case '+': case '?': if (obscure_syntax & RE_BK_PLUS_QM) goto handle_plus; default: normal_backsl: /* You might think it would be useful for \ to mean not to translate; but if we don't translate it it will never match anything. */ if (translate) c = translate[c]; goto normal_char; } break; default: normal_char: if (!pending_exact || pending_exact + *pending_exact + 1 != b || *pending_exact == 0177 || *p == '*' || *p == '^' || ((obscure_syntax & RE_BK_PLUS_QM) ? *p == '\\' && (p[1] == '+' || p[1] == '?') : (*p == '+' || *p == '?'))) { laststart = b; PATPUSH (exactn); pending_exact = b; PATPUSH (0); } PATPUSH (c); (*pending_exact)++; } } if (fixup_jump) store_jump (fixup_jump, jump, b); if (stackp != stackb) goto unmatched_open; bufp->used = b - bufp->buffer; return 0; invalid_pattern: return "Invalid regular expression"; unmatched_open: return "Unmatched \\("; unmatched_close: return "Unmatched \\)"; end_of_pattern: return "Premature end of regular expression"; nesting_too_deep: return "Nesting too deep"; too_big: return "Regular expression too big"; memory_exhausted: return "Memory exhausted";}/* Store where `from' points a jump operation to jump to where `to' points. `opcode' is the opcode to store. */static intstore_jump (from, opcode, to) char *from, *to; char opcode;{ from[0] = opcode; from[1] = (to - (from + 3)) & 0377; from[2] = (to -
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:Grep ƒ:regex.c
+++++ Continued from previous card +++++
(from + 3)) >> 8;}/* Open up space at char FROM, and insert there a jump to TO. CURRENT_END gives te end of the storage no in use, so we know how much data to copy up. OP is the opcode of the jump to insert. If you call this function, you must zero out pending_exact. */static intinsert_jump (op, from, to, current_end) char op; char *from, *to, *current_end;{ register char *pto = current_end + 3; register char *pfrom = current_end; while (pfrom != from) *--pto = *--pfrom; store_jump (from, op, to);}/* Given a pattern, compute a fastmap from it. The fastmap records which of the (1 << BYTEWIDTH) possible characters can start a string that matches the pattern. This fastmap is used by re_search to skip quickly over totally implausible text. The caller must supply the address of a (1 << BYTEWIDTH)-byte data area as bufp->fastmap. The other components of bufp describe the pattern to be used. */voidre_compile_fastmap (bufp) struct re_pattern_buffer *bufp;{ unsigned char *pattern = (unsigned char *) bufp->buffer; int size = bufp->used; register char *fastmap = bufp->fastmap; register unsigned char *p = pattern; register unsigned char *pend = pattern + size; register int j;#ifdef emacs register int k;#endif unsigned char *translate = (unsigned char *) bufp->translate; unsigned char *stackb[NFAILURES]; unsigned char **stackp = stackb; bzero (fastmap, (1 << BYTEWIDTH)); bufp->fastmap_accurate = 1; bufp->can_be_null = 0; while (p) { if (p == pend) { bufp->can_be_null = 1; break; }#ifdef SWITCH_ENUM_BUG switch ((int) ((enum regexpcode) *p++))#else switch ((enum regexpcode) *p++)#endif { case exactn: if (translate) fastmap[translate[p[1]]] = 1; else fastmap[p[1]] = 1; break; case begline: case before_dot: case at_dot: case after_dot: case begbuf: case endbuf: case wordbound: case notwordbound: case wordbeg: case wordend: continue; case endline: if (translate) fastmap[translate['\n']] = 1; else fastmap['\n'] = 1; if (bufp->can_be_null != 1) bufp->can_be_null = 2; break; case finalize_jump: case maybe_finalize_jump: case jump: case dummy_failure_jump: bufp->can_be_null = 1; j = *p++ & 0377; j += SIGN_EXTEND_CHAR (*(char *)p) << 8; p += j + 1; /* The 1 compensates for missing ++ above */ if (j > 0) continue; /* Jump backward reached implies we just went through the body of a loop and matched nothing. Opcode jumped to should be an on_failure_jump. Just treat it like an ordinary jump. For a * loop, it has pushed its failure point already; if so, discard that as redundant. */ if ((enum regexpcode) *p != on_failure_jump) continue; p++; j = *p++ & 0377; j += SIGN_EXTEND_CHAR (*(char *)p) << 8; p += j + 1; /* The 1 compensates for missing ++ above */ if (stackp != stackb && *stackp == p) stackp--; continue; case on_failure_jump: j = *p++ & 0377; j += SIGN_EXTEND_CHAR (*(char *)p) << 8; p++; *++stackp = p + j; continue; case start_memory: case stop_memory: p++; continue; case duplicate: bufp->can_be_null = 1; fastmap['\n'] = 1; case anychar: for (j = 0; j < (1 << BYTEWIDTH); j++) if (j != '\n') fastmap[j] = 1; if (bufp->can_be_null) return; /* Don't return; check the alternative paths so we can set can_be_null if appropriate. */ break; case wordchar: for (j = 0; j < (1 << BYTEWIDTH); j++) if (SYNTAX (j) == Sword) fastmap[j] = 1; break; case notwordchar: for (j = 0; j < (1 << BYTEWIDTH); j++) if (SYNTAX (j) != Sword) fastmap[j] = 1; break;#ifdef emacs case syntaxspec: k = *p++; for (j = 0; j < (1 << BYTEWIDTH); j++) if (SYNTAX (j) == (enum syntaxcode) k) fastmap[j] = 1; break; case notsyntaxspec: k = *p++; for (j = 0; j < (1 << BYTEWIDTH); j++) if (SYNTAX (j) != (enum syntaxcode) k) fastmap[j] = 1; break;#endif /* emacs */ case charset: for (j = *p++ * BYTEWIDTH - 1; j >= 0; j--) if (p[j / BYTEWIDTH] & (1 << (j % BYTEWIDTH))) { if (translate) fastmap[translate[j]] = 1; else fastmap[j] = 1; } break; case charset_not: /* Chars beyond end of map must be allowed */ for (j = *p * BYTEWIDTH; j < (1 << BYTEWIDTH); j++) if (translate) fastmap[translate[j]] = 1; else fastmap[j] = 1; for (j = *p++ * BYTEWIDTH - 1; j >= 0; j--) if (!(p[j / BYTEWIDTH] & (1 << (j % BYTEWIDTH)))) { if (translate) fastmap[translate[j]] = 1; else fastmap[j] = 1; } break; } /* Get here means we have successfully found the possible starting characters of one path of the pattern. We need not follow this path any farther. Instead, look at the next alternative remembered in the stack. */ if (stackp != stackb) p = *stackp--; else break; }}/* Like re_search_2, below, but only one string is specified. */intre_search (pbufp, string, size, startpos, range, regs) struct re_pattern_buffer *pbufp; char *string; int size, startpos, range; struct re_registers *regs;{ return re_search_2 (pbufp, 0, 0, string, size, startpos, range, regs, size);}/* Like re_match_2 but tries first a match starting at index STARTPOS, then at STARTPOS + 1, and so on. RANGE is the number of places to try before giving up. If RANGE is negative, the starting positions tried are STARTPOS, STARTPOS - 1, etc. It is up to the caller to make sure that range is not so large as to take the starting position outside of the input strings.The value returned is the position at which the match was found, or -1 if no match was found, or -2 if error (such as failure stack overflow). */intre_search_2 (pbufp, string1, size1, string2, size2, startpos, range, regs, mstop) struct re_pattern_buffer *pbufp; char *string1, *string2; int size1, size2; int startpos; register int range; struct re_registers *regs; int mstop;{ register char *fastmap = pbufp->fastmap; register unsigned char *translate = (unsigned char *) pbufp->translate; int total = size1 + size2; int val; /* Update the fastmap now if not correct already */ if (fastmap && !pbufp->fastmap_accurate) re_compile_fastmap (pbufp); /* Don't waste time in a long search for a pattern that says it is anchored. */ if (pbufp->used > 0 && (enum regexpcode) pbufp->buffer[0] == begbuf && range > 0) { if (startpos > 0) return -1; else range = 1; } while (1) { /* If a fastmap is supplied, skip quickly over characters that cannot possibly be the start of a match. Note, however, that if the pattern can possibly match the null string, we must test it at each starting point so that we take the first null string we get. */ if (fastmap && startpos < total && pbufp->can_be_null != 1) { if (range > 0) { register int lim = 0; register unsigned char *p; int irange = range; if (startpos < size1 && startpos + range >= size1) lim = range - (size1 - startpos); p = ((unsigned char *) &(startpos >= size1 ? string2 - size1 : string1)[startpos]); if (translate) { while (range > lim && !fastmap[translate[*p++]]) range--; } else { while (range > lim && !fastmap[*p++]) range--; } startpos += irange - range; } else { register unsigned char c; if (startpos >= size1) c = string2[startpos - size1]; else c = string1[startpos]; c &= 0xff; if (translate ? !fastmap[translate[c]] : !fastmap[c]) goto advance; } } if (range >= 0 && startpos == total && fastmap && pbufp->can_be_null == 0) return -1; val = re_match_2 (pbufp, string1, size1, string2, size2, startpos, regs, mstop); if (0 <= val) { if (val == -2) return -2; return startpos; }#ifdef C_ALLOCA alloca (0);#endif /* C_ALLOCA */ advance: if (!range) break; if (range > 0) range--, startpos++; else range++, startpos--; } return -1;} #ifndef emacs /* emacs never uses this */intre_match (pbufp, string, size, pos, regs) struct re_pattern_buffer *pbufp; char *string; int size, pos; struct re_registers *regs;{ return re_match_2 (pbufp, 0, 0, string, size, pos, regs, size);}#endif /* emacs *//* Maximum size of failure stack. Beyond this, overflow is an error. */int re_max_failures = 2000;static int bcmp_translate();/* Match the pattern described by PBUFP against data which is the virtual concatenation of STRING1 and STRING2. SIZE1 and SIZE2 are the sizes of the two data strings. Start the match at position POS. Do not consider matching past the position MSTOP. If pbufp->fastmap is nonzero, then it had better be up to date. The reason that the data to match are specified as two components which are to be regarded as concatenated is so this function can be used directly on the contents of an Emacs buffer. -1 is returned if there is no match. -2 is returned if there is an error (such as match stack overflow). Otherwise the value is the length of the substring which was matched. */intre_match_2 (pbufp, string1, size1, string2, size2, pos, regs, mstop) struct re_pattern_buffer *pbufp; unsigned char *string1, *string2; int size1, size2; int pos; struct re_registers *regs; int mstop;{ register unsigned char *p = (unsigned char *) pbufp->buffer; register unsigned char *pend = p + pbufp->used; /* End of first string */ unsigned char *end1; /* End of second string */ unsigned char *end2; /* Pointer just past last char to consider matching */ unsigned char *end_match_1, *end_match_2; register unsigned char *d, *dend; register int mcnt; unsigned char *translate = (unsigned char *) pbufp->translate; /* Failure point stack. Each place that can handle a failure further down the line pushes a failure point on this stack. It consists of two char *'s. The first one pushed is where to resume scanning the pattern; the second pushed is where to resume scanning the strings. If the latter is zero, the failure point is a "dummy". If a failure happens and the innermost failure point is dormant, it discards that failure point and tries the next one. */ unsigned char *initial_stack[2 * NFAILURES]; unsigned char **stackb = initial_stack; unsigned char **stackp = stackb, **stacke = &stackb[2 * NFAILURES]; /* Information on the "contents" of registers. These are pointers into the input strings; they record just what was matched (on this attempt) by some part of the pattern. The start_memory command stores the start of a register's contents and the stop_memory command stores the end. At that point, regstart[regnum] points to the first character in the register, regend[regnum] points to the first character beyond the end of the register, regstart_seg1[regnum] is true iff regstart[regnum] points into string1, and regend_seg1[regnum] is true iff regend[regnum] points into string1. */ unsigned char *regstart[RE_NREGS]; unsigned char *regend[RE_NREGS]; unsigned char regstart_seg1[RE_NREGS], regend_seg1[RE_NREGS]; /* Set up pointers to ends of strings. Don't allow the second string to be empty unless both are empty. */ if (!size2) { string2 = string1; size2 = size1; string1 = 0; size1 = 0; } end1 = string1 + size1; end2 = string2 + size2; /* Compute where to stop matching, within the two strings */ if (mstop <= size1) { end_match_1 = string1 + mstop; end_match_2 = string2; } else { end_match_1 = end1; end_match_2 = string2 + mstop - size1; } /* Initialize \) text positions to -1 to mark ones that no \( or \) has been seen for. */ for (mcnt = 0; mcnt < sizeof (regend) / sizeof (*regend); mcnt++) regend[mcnt] = (unsigned char *) -1; /* `p' scans through the pattern as `d' scans through the data. `dend' is the end of the input string that `d' points within. `d' is advanced into the following input string whenever necessary, but this happens before fetching; therefore, at the beginning of the loop, `d' can be pointing at the end of a string, but it cannot equal string2. */ if (pos <= size1) d = string1 + pos, dend = end_match_1; else d = string2 + pos - size1, dend = end_match_2;/* Write PREFETCH; just before fetching a character with *d. */#define PREFETCH \ while (d == dend) \ { if (dend == end_match_2) goto fail; /* end of string2 => failure */ \ d = string2; /* end of string1 => advance to string2. */ \ dend = end_match_2; } /* This loop loops over pattern commands. It exits by returning from the function if match is complete, or it drops through if match fails at this starting point in the input data. */ while (1) { if (p == pend) /* End of pattern means we have succeeded! */ { /* If caller wants register contents data back, convert it to indices */ if (regs) { regs->start[0] = pos; if (dend == end_match_1) regs->end[0] = d - string1; else regs->end[0] = d - string2 + size1; for (mcnt = 1; mcnt < RE_NREGS; mcnt++) { if (regend[mcnt] == (unsigned char *) -1) { regs->start[mcnt] = -1; regs->end[mcnt] = -1; continue; } if (regstart_seg1[mcnt]) regs->start[mcnt] = regstart[mcnt] - string1; else regs->start[mcnt] = regstart[mcnt] - string2 + size1; if (regend_seg1[mcnt]) regs->end[mcnt] = regend[mcnt] - string1; else regs->end[mcnt] = regend[mcnt] - string2 + size1; } } if (dend == end_match_1) return (d - string1 - pos); else return d - string2 + size1 - pos; } /* Otherwise match next pattern command */#ifdef SWITCH_ENUM_BUG switch ((int) ((enum regexpcode) *p++))#else switch ((enum regexpcode) *p++)#endif { /* \( is represented by a start_memory, \) by a stop_memory. Both of those commands contain a "register number" argument. The text matched within the \( and \) is recorded under that number. Then, \<digit> turns into a `duplicate' command which is followed by the numeric value of <digit> as the register number. */ case start_memory: regstart[*p] = d; regstart_seg1[*p++] = (dend == end_match_1); break; case stop_memory: regend[*p] = d; regend_seg1[*p++] = (dend == end_match_1); break; case duplicate: { int regno = *p++; /* Get which register to match against */ register unsigned char *d2, *dend2; d2 = regstart[regno]; dend2 = ((regstart_seg1[regno] == regend_seg1[regno]) ? regend[regno] : end_match_1); while (1) { /* Advance to next segment in register contents, if necessary */ while (d2 == dend2) { if (dend2 == end_match_2) break; if (dend2 == regend[regno]) break; d2 = string2, dend2 = regend[regno]; /* end of string1 => advance to string2. */ } /* At end of register contents => success */ if (d2 == dend2) break; /* Advance to next segment in data being matched, if necessary */ PREFETCH; /* mcnt gets # consecutive chars to compare */ mcnt = dend - d; if (mcnt > dend2 - d2) mcnt = dend2 - d2; /* Compare that many; failure if mismatch, else skip them. */ if (translate ? bcmp_translate (d, d2, mcnt, translate) : bcmp (d, d2, mcnt)) goto
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:Grep ƒ:regex.c
+++++ Continued from previous card +++++
fail; d += mcnt, d2 += mcnt; } } break; case anychar: /* fetch a data character */ PREFETCH; /* Match anything but a newline. */ if ((translate ? translate[*d++] : *d++) == '\n') goto fail; break; case charset: case charset_not: { /* Nonzero for charset_not */ int not = 0; register int c; if (*(p - 1) == (unsigned char) charset_not) not = 1; /* fetch a data character */ PREFETCH; if (translate) c = translate [*d]; else c = *d; if (c < *p * BYT && p[1 + c / BYTEWIDTH] & (1 << (c % BYTEWIDTH))) not = !not; p += 1 + *p; if (!not) goto fail; d++; break; } case begline: if (d == string1 || d[-1] == '\n') break; goto fail; case endline: if (d == end2 || (d == end1 ? (size2 == 0 || *string2 == '\n') : *d == '\n')) break; goto fail; /* "or" constructs ("|") are handled by starting each alternative with an on_failure_jump that points to the start of the next alternative. Each alternative except the last ends with a jump to the joining point. (Actually, each jump except for the last one really jumps to the following jump, because tensioning the jumps is a hassle.) */ /* The start of a stupid repeat has an on_failure_jump that points past the end of the repeat text. This makes a failure point so that, on failure to match a repetition, matching restarts past as many repetitions have been found with no way to fail and look for another one. */ /* A smart repeat is similar but loops back to the on_failure_jump so that each repetition makes another failure point. */ case on_failure_jump: if (stackp == stacke) { unsigned char **stackx; if (stacke - stackb > re_max_failures * 2) return -2; stackx = (unsigned char **) alloca (2 * (stacke - stackb) * sizeof (char *)); bcopy (stackb, stackx, (stacke - stackb) * sizeof (char *)); stackp = stackx + (stackp - stackb); stacke = stackx + 2 * (stacke - stackb); stackb = stackx; } mcnt = *p++ & 0377; mcnt += SIGN_EXTEND_CHAR (*(char *)p) << 8; p++; *stackp++ = mcnt + p; *stackp++ = d; break; /* The end of a smart repeat has an maybe_finalize_jump back. Change it either to a finalize_jump or an ordinary jump. */ case maybe_finalize_jump: mcnt = *p++ & 0377; mcnt += SIGN_EXTEND_CHAR (*(char *)p) << 8; p++; { register unsigned char *p2 = p; /* Compare what follows with the begining of the repeat. If we can establish that there is nothing that they would both match, we can change to finalize_jump */ while (p2 != pend && (*p2 == (unsigned char) stop_memory || *p2 == (unsigned char) start_memory)) p2++; if (p2 == pend) p[-3] = (unsigned char) finalize_jump; else if (*p2 == (unsigned char) exactn || *p2 == (unsigned char) endline) { register int c = *p2 == (unsigned char) endline ? '\n' : p2[2]; register unsigned char *p1 = p + mcnt; /* p1[0] ... p1[2] are an on_failure_jump. Examine what follows that */ if (p1[3] == (unsigned char) exactn && p1[5] != c) p[-3] = (unsigned char) finalize_jump; else if (p1[3] == (unsigned char) charset || p1[3] == (unsigned char) charset_not) { int not = p1[3] == (unsigned char) charset_not; if (c < p1[4] * BYTEWIDTH && p1[5 + c / BYTEWIDTH] & (1 << (c % BYTEWIDTH))) not = !not; /* not is 1 if c would match */ /* That means it is not safe to finalize */ if (!not) p[-3] = (unsigned char) finalize_jump; } } } p -= 2; if (p[-1] != (unsigned char) finalize_jump) { p[-1] = (unsigned char) jump; goto nofinalize; } /* The end of a stupid repeat has a finalize-jump back to the start, where another failure point will be made which will point after all the repetitions found so far. */ case finalize_jump: stackp -= 2; case jump: nofinalize: mcnt = *p++ & 0377; mcnt += SIGN_EXTEND_CHAR (*(char *)p) << 8; p += mcnt + 1; /* The 1 compensates for missing ++ above */ break; case dummy_failure_jump: if (stackp == stacke) { unsigned char **stackx = (unsigned char **) alloca (2 * (stacke - stackb) * sizeof (char *)); bcopy (stackb, stackx, (stacke - stackb) * sizeof (char *)); stackp = stackx + (stackp - stackb); stacke = stackx + 2 * (stacke - stackb); stackb = stackx; } *stackp++ = 0; *stackp++ = 0; goto nofinalize; case wordbound: if (d == string1 /* Points to first char */ || d == end2 /* Points to end */ || (d == end1 && size2 == 0)) /* Points to end */ break; if ((SYNTAX (d[-1]) == Sword) != (SYNTAX (d == end1 ? *string2 : *d) == Sword)) break; goto fail; case notwordbound: if (d == string1 /* Points to first char */ || d == end2 /* Points to end */ || (d == end1 && size2 == 0)) /* Points to end */ goto fail; if ((SYNTAX (d[-1]) == Sword) != (SYNTAX (d == end1 ? *string2 : *d) == Sword)) goto fail; break; case wordbeg: if (d == end2 /* Points to end */ || (d == end1 && size2 == 0) /* Points to end */ || SYNTAX (* (d == end1 ? string2 : d)) != Sword) /* Next char not a letter */ goto fail; if (d == string1 /* Points to first char */ || SYNTAX (d[-1]) != Sword) /* prev char not letter */ break; goto fail; case wordend: if (d == string1 /* Points to first char */ || SYNTAX (d[-1]) != Sword) /* prev char not letter */ goto fail; if (d == end2 /* Points to end */ || (d == end1 && size2 == 0) /* Points to end */ || SYNTAX (d == end1 ? *string2 : *d) != Sword) /* Next char not a letter */ break; goto fail;#ifdef emacs case before_dot: if (((d - string2 <= (unsigned) size2) ? d - bf_p2 : d - bf_p1) <= point) goto fail; break; case at_dot: if (((d - string2 <= (unsigned) size2) ? d - bf_p2 : d - bf_p1) == point) goto fail; break; case after_dot: if (((d - string2 <= (unsigned) size2) ? d - bf_p2 : d - bf_p1) >= point) goto fail; break; case wordchar: mcnt = (int) Sword; goto matchsyntax; case syntaxspec: mcnt = *p++; matchsyntax: PREFETCH; if (SYNTAX (*d++) != (enum syntaxcode) mcnt) goto fail; break; case notwordchar: mcnt = (int) Sword; goto matchnotsyntax; case notsyntaxspec: mcnt = *p++; matchnotsyntax: PREFETCH; if (SYNTAX (*d++) == (enum syntaxcode) mcnt) goto fail; break;#else case wordchar: PREFETCH; if (SYNTAX (*d++) == 0) goto fail; break; case notwordchar: PREFETCH; if (SYNTAX (*d++) != 0) goto fail; break;#endif /* not emacs */ case begbuf: if (d == string1) /* Note, d cannot equal string2 */ break; /* unless string1 == string2. */ goto fail; case endbuf: if (d == end2 || (d == end1 && size2 == 0)) break; goto fail; case exactn: /* Match the next few pattern characters exactly. mcnt is how many characters to match. */ mcnt = *p++; if (translate) { do { PREFETCH; if (translate[*d++] != *p++) goto fail; } while (--mcnt); } else { do { PREFETCH; if (*d++ != *p++) goto fail; } while (--mcnt); } break; } continue; /* Successfully matched one pattern command; keep matching */ /* Jump here if any matching operation fails. */ fail: if (stackp != stackb) /* A restart point is known. Restart there and pop it. */ { if (!stackp[-2]) { /* If innermost failure point is dormant, flush it and keep looking */ stackp -= 2; goto fail; } d = *--stackp; p = *--stackp; if (d >= string1 && d <= end1) dend = end_match_1; } else break; /* Matching at this starting point really fails! */ } return -1; /* Failure to match */}static intbcmp_translate (s1, s2, len, translate) unsigned char *s1, *s2; register int len; unsigned char *translate;{ register unsigned char *p1 = s1, *p2 = s2; while (len) { if (translate [*p1++] != translate [*p2++]) return 1; len--; } return 0;} /* Entry points compatible with bsd4.2 regex library */#ifndef emacsstatic struct re_pattern_buffer re_comp_buf;char *re_comp (s) char *s;{ if (!s) { if (!re_comp_buf.buffer) return "No previous regular expression"; return 0; } if (!re_comp_buf.buffer) { if (!(re_comp_buf.buffer = (char *) malloc (200))) return "Memory exhausted"; re_comp_buf.allocated = 200; if (!(re_comp_buf.fastmap = (char *) malloc (1 << BYTEWIDTH))) return "Memory exhausted"; } return re_compile_pattern (s, strlen (s), &re_comp_buf);}intre_exec (s) char *s;{ int len = strlen (s); return 0 <= re_search (&re_comp_buf, s, len, 0, len, 0);}#endif /* emacs */ #ifdef test#include <stdio.h>/* Indexed by a character, gives the upper case equivalent of the character */static char upcase[0400] = { 000, 001, 002, 003, 004, 005, 006, 007, 010, 011, 012, 013, 014, 015, 016, 017, 020, 021, 022, 023, 024, 025, 026, 027, 030, 031, 032, 033, 034, 035, 036, 037, 040, 041, 042, 043, 044, 045, 046, 047, 050, 051, 052, 053, 054, 055, 056, 057, 060, 061, 062, 063, 064, 065, 066, 067, 070, 071, 072, 073, 074, 075, 076, 077, 0100, 0101, 0102, 0103, 0104, 0105, 0106, 0107, 0110, 0111, 0112, 0113, 0114, 0115, 0116, 0117, 0120, 0121, 0122, 0123, 0124, 0125, 0126, 0127, 0130, 0131, 0132, 0133, 0134, 0135, 0136, 0137, 0140, 0101, 0102, 0103, 0104, 0105, 0106, 0107, 0110, 0111, 0112, 0113, 0114, 0115, 0116, 0117, 0120, 0121, 0122, 0123, 0124, 0125, 0126, 0127, 0130, 0131, 0132, 0173, 0174, 0175, 0176, 0177, 0200, 0201, 0202, 0203, 0204, 0205, 0206, 0207, 0210, 0211, 0212, 0213, 0214, 0215, 0216, 0217, 0220, 0221, 0222, 0223, 0224, 0225, 0226, 0227, 0230, 0231, 0232, 0233, 0234, 0235, 0236, 0237, 0240, 0241, 0242, 0243, 0244, 0245, 0246, 0247, 0250, 0251, 0252, 0253, 0254, 0255, 0256, 0257, 0260, 0261, 0262, 0263, 0264, 0265, 0266, 0267, 0270, 0271, 0272, 0273, 0274, 0275, 0276, 0277, 0300, 0301, 0302, 0303, 0304, 0305, 0306, 0307, 0310, 0311, 0312, 0313, 0314, 0315, 0316, 0317, 0320, 0321, 0322, 0323, 0324, 0325, 0326, 0327, 0330, 0331, 0332, 0333, 0334, 0335, 0336, 0337, 0340, 0341, 0342, 0343, 0344, 0345, 0346, 0347, 0350, 0351, 0352, 0353, 0354, 0355, 0356, 0357, 0360, 0361, 0362, 0363, 0364, 0365, 0366, 0367, 0370, 0371, 0372, 0373, 0374, 0375, 0376, 0377 };main (argc, argv) int argc; char **argv;{ char pat[80]; struct re_pattern_buffer buf; int i; char c; char fastmap[(1 << BYTEWIDTH)]; /* Allow a command argument to specify the style of syntax. */ if (argc > 1) obscure_syntax = atoi (argv[1]); buf.allocated = 40; buf.buffer = (char *) malloc (buf.allocated); buf.fastmap = fastmap; buf.translate = upcase; while (1) { gets (pat); if (*pat) { re_compile_pattern (pat, strlen(pat), &buf); for (i = 0; i < buf.used; i++) printchar (buf.buffer[i]); putchar ('\n'); printf ("%d allocated, %d used.\n", buf.allocated, buf.used); re_compile_fastmap (&buf); printf ("Allowed by fastmap: "); for (i = 0; i < (1 << BYTEWIDTH); i++) if (fastmap[i]) printchar (i); putchar ('\n'); } gets (pat); /* Now read the string to match against */ i = re_match (&buf, pat, strlen (pat), 0, 0); printf ("Match value %d.\n", i); }}#ifdef NOTDEFprint_buf (bufp) struct re_pattern_buffer *bufp;{ int i; printf ("buf is :\n----------------\n"); for (i = 0; i < bufp->used; i++) printchar (bufp->buffer[i]); printf ("\n%d allocated, %d used.\n", bufp->allocated, bufp->used); printf ("Allowed by fastmap: "); for (i = 0; i < (1 << BYTEWIDTH); i++) if (bufp->fastmap[i]) printchar (i); printf ("\nAllowed by translate: "); if (bufp->translate) for (i = 0; i < (1 << BYTEWIDTH); i++) if (bufp->translate[i]) printchar (i); printf ("\nfastmap is%s accurate\n", bufp->fastmap_accurate ? "" : "n't"); printf ("can %s be null\n----------", bufp->can_be_null ? "" : "not");}#endifprintchar (c) char c;{ if (c < 041 || c >= 0177) { putchar ('\\'); putchar (((c >> 6) & 3) + '0'); putchar (((c >> 3) & 7) + '0'); putchar ((c & 7) + '0'); } else putchar (c);}error (string) char *string;{ puts (string); exit (1);}#endif /* test */ :MPW:MPW Tools:Tools with Source:Grep ƒ:regex.h
/* Definitions for data structures callers pass the regex library. Copyright (C) 1985, 1989 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. In other words, you are welcome to use, share and improve this program. You are forbidden to forbid anyone else to use, share and improve what you give them. Help stamp out software-hoarding! *//* Define number of parens for which we record the beginnings and ends. This affects how much space the `struct re_registers' type takes up. */#ifndef RE_NREGS#define RE_NREGS 10#endif/* These bits are used in the obscure_syntax variable to choose among alternative regexp syntaxes. *//* 1 means plain parentheses serve as grouping, and backslash parentheses are needed for literal searching. 0 means backslash-parentheses are grouping, and plain parentheses are for literal searching. */#define RE_NO_BK_PARENS 1/* 1 means plain | serves as the "or"-operator, and \| is a literal. 0 means \| serves as the "or"-operator, and | is a literal. */#define RE_NO_BK_VBAR 2/* 0 means plain + or ? serves as an operator, and \+, \? are literals. 1 means \+, \? are operators and plain +, ? are literals. */#define RE_BK_PLUS_QM 4/* 1 means | binds tighter than ^ or $. 0 means the contrary. */#define RE_TIGHT_VBAR 8/* 1 means treat \n as an _OR operator 0 means treat it as a normal character */#define RE_NEWLINE_OR 16/* 0 means that a special characters (such as *, ^, and $) always have their special meaning regardless of the surrounding context. 1 means that special characters may act as normal characters in some contexts. Specifically, this applies to: ^ - only special at the beginning, or after ( or | $ - only special at the end, or before ) or | *, +, ? - only special when not after the beginning, (, or | */#define RE_CONTEXT_INDEP_OPS 32/* Now define combinations of bits for the standard possibilities. */#define RE_SYNTAX_AWK (RE_NO_BK_PARENS | RE_NO_BK_VBAR | RE_CONTEXT_INDEP_OPS)#define RE_SYNTAX_EGREP (RE_SYNTAX_AWK | RE_NEWLINE_OR)#define RE_SYNTAX_GREP (RE_BK_PLUS_QM | RE_NEWLINE_OR)#define RE_SYNTAX_EMACS 0/* This data structure is used to represent a compiled pattern. */struct re_pattern_buffer { char *buffer; /* Space holding the compiled pattern commands. */ int allocated; /* Size of space that buffer points to */ int used; /* Length of portion of buffer actually occupied */ char *fastmap; /* Pointer to fastmap, if any, or zero if none. */ /* re_search uses the fastmap, if there is one, to skip quickly over totally implausible characters */ char *translate; /* Translate table to apply to all characters before comparing. Or zero for no translation. The translation is applied to a pattern when it is compiled and to data when it is matched. */ char fastmap_accurate; /* Set to zero when a new pattern is stored, set to one when the fastmap is updated from it. */ char can_be_null; /* Set to one by compiling fastmap if this pattern might match the null string. It does not necessarily match the null string in that case, but if this is zero, it cannot. 2 as value means can match null string but at end of range or before a character listed in the fastmap. */ };/* Structure to store "register" contents data in. Pass the address of such a structure as an argument to re_match, etc., if you want this information back. start[i] and end[i] record the string matched by \( ... \) grouping i, for i from 1 to RE_NREGS - 1. start[0] and end[0] record the entire string matched. */struct re_registers { int start[RE_NREGS]; int end[RE_NREGS]; };/* These are the command codes that appear in compiled regular expressions, one per byte. Some command codes are followed by argument bytes. A command code can specify any interpretation whatever for its arguments. Zero-bytes may appear in the compiled regular expression. */enum regexpcode { unused, exactn, /* followed by one byte giving n, and then by n literal bytes */ begline, /* fails unless at beginning of line */ endline, /* fails unless at end of line */ jump, /* followed by two bytes giving relative address to jump to */ on_failure_jump, /* followed by two bytes giving relative address of place to resume at in case of failure. */ finalize_jump, /* Throw away latest failure point and then jump to address. */ maybe_finalize_jump, /* Like jump but finalize if safe to do so. This is used to jump back to the beginning of a repeat. If the command that follows this jump is clearly incompatible with the one at the beginning of the repeat, such that we can be sure that there is no use backtracking out of repetitions already completed, then we finalize. */ dummy_failure_jump, /* jump, and push a dummy failure point. This failure point will be thrown away if an attempt is made to use it for a failure. A + construct makes this before the first repeat. */ anychar, /* matches any one character */ charset, /* matches any one char belonging to specified set. First following byte is # bitmap bytes. Then come bytes for a bit-map saying which chars are in. Bits in each byte are orderit-first. A character is in the set if its bit is 1. A character too large to have a bit in the map is automatically not in the set */ charset_not, /* similar but match any character that is NOT one of those specified */ start_memory, /* starts remembering the text that is matched and stores it in a memory register. followed by one byte containing the register number. Register numbers must be in the range 0 through NREGS. */ stop_memory, /* stops remembering the text that is matched and stores it in a memory register. followed by one byte containing the register number. Register numbers must be in the range 0 through NREGS. */ duplicate, /* match a duplicate of something remembered. Followed by one byte containing the index of the memory register. */ before_dot, /* Succeeds if before dot */ at_dot, /* Succeeds if at dot */ after_dot, /* Succeeds if after dot */ begbuf, /* Succeeds if at beginning of buffer */ endbuf, /* Succeeds if at end of buffer */ wordchar, /* Matches any word-constituent character */ notwordchar, /* Matches any char that is not a word-constituent */ wordbeg, /* Succeeds if at word beginning */ wordend, /* Succeeds if at word end */ wordbound, /* Succeeds if at a word boundary */ notwordbound, /* Succeeds if not at a word boundary */ syntaxspec, /* Matches any character whose syntax is specified. followed by a byte which contains a syntax code, Sword or such like */ notsyntaxspec /* Matches any character whose syntax differs from the specified. */ }; extern char *re_compile_pattern ();/* Is this really advertised? */extern void re_compile_fastmap ();extern int re_search (), re_search_2 ();extern int re_match (), re_match_2 ();/* 4.2 bsd compatibility (yuck) */extern char *re_comp ();extern int re_exec ();#ifdef SYNTAX_TABLEextern char *re_syntax_table;#endif :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:bench Folder:Compile
for i in {"parameters"} icont -s "{i}"end :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:bench Folder:concord.dat
ICONT(1) UNIX Programmer's Manual ICONT(1)NAME icont - process Icon programsSYNOPSIS icont [ option ... ] file ... [ -x arg ... ]DESCRIPTION The program icont is a command processor for running Version 8 Icon programs. Used in its simplest form, it produces a file suitable for interpretation by the Icon interpreter. Processing consists of two phases: translation and linking. During translation, each Icon source file is translated into an intermediate language called ucode; during linking, the one or more ucode files are combined and a single icode file is produced. Unless the -o option is specified, the name of the resulting icode file is formed by deleting the suffix of the first input file named on the command line. If the -x argument is used, the file is automatically executed by the interpreter and any arguments following the -x are passed as execution arguments to the Icon program itself. Files whose names end in .icn are assumed to be Icon source programs. The .icn suffix may be omitted; it will be sup- plied automatically. These programs are translated, and the intermediate code is left in two ucode files of the same name with .u1 and .u2 substituted for .icn. The ucode files normally are deleted when icont completes. Files whose names end in .u1 are assumed to refer to ucode files from a previous translation; these files and the corresponding .u2 files are included in the linking phase after any .icn files have been translated. The suffix .u can be used in place of .u1; in this case the 1 is supplied automatically. A .u1 or .u2 file that is explicitly named is not deleted. Icon source programs may be read from standard input. The argu- ment - signifies the use of standard input as a source file. In this case, the ucode files are named stdin.u1 and stdin.u2 and the icode file is named stdin. The following options are recognized by icont: -c Suppress the linking phase. The ucode code files are not deleted. -m Preprocess each .icn source file with the m4(1) macro processor before translation. -o output Name the icode file output. -s Suppress informative messages from the translator and linker. Normally, both informative messages and error messages are sent to standard error output. -t Arrange for &trace to have an initial value of -1 whenPrinted 12/29/89Icon Project - 1/1/1990 - IPD109 1ICONT(1) UNIX Programmer's Manual ICONT(1) the program is executed. Normally, &trace has an ini- tial value of 0. -u Issue warning messages for undeclared identifiers in the program. The warnings are issued during the linking phase. Icon has several tables related to the translation and link- ing of programs. These tables are large enough for most programs, but their sizes can be changed, if necessary, by the -S option. This option has the form -S[cfgilnrstCFL]n, where the letter following the S specifies the table and n is the number of storage units to allocate for the table. The tables and their default sizes are: c constant table 100 f field table 100 g global symbol table 200 i identifier table 500 l local symbol table 100 n line number space 1000 r field table for records 100 s string space 20000 t tree space 15000 C code buffer 15000 F file names 10 L labels 500 The units depend on the table involved, but the default values can be used as a general guide for appropriate set- tings of -S options without knowing the units. The environment variable IPATH controls the location of files specified in link directives. The value of IPATH should be a blank-separated string of the form p1 p2 ... pn where the pi name directories. Each directory is searched in turn to locate files named in link directives. The default value for IPATH is . , that is, the current direc- tory. The current path is always searched first, regardless of the value of IPATH. The icode file produced by the Icon linker is executable. For example, the command icont hello.icn produces a file named hello that can be run by the command hello Arguments can be passed to the Icon program by following the program name with the arguments. Any such arguments are passed to the main procedure as a list of strings.Printed 12/29/89Icon Project - 1/1/1990 - IPD109 2ICONT(1) UNIX Programmer's Manual ICONT(1) The location of iconx, the executor for icode files, is built into an icode file when it is produced. This location can be overridden by setting the environment variable ICONX as described below. If ICONX is not set and iconx is not found on the built-in path, PATH is searched for it. When an Icon program is executed, several environment vari- ables are examined to determine certain execution parame- ters. Expect for ICONX, NOERRBUF, and ICONCORE, the values assigned to these variables should be numbers. The vari- ables that affect execution and the interpretations of their values follow. Numbers in parentheses are the default values. ICONX If this environment variable is set, it specifies the location of iconx to use to execute an icode file. TRACE Initialize the value of &trace. If this variable has a value, it overrides the translation-time -t option. NOERRBUF By default, &errout is buffered. If this variable is set, &errout is not buffered. ICONCORE If set, a core dump is produced for error termination. STRSIZE (65000) The initial size of the string space, in bytes. The string space grows if necessary, but it never shrinks. HEAPSIZE (65000) The initial size of the allocated block region, in bytes. The block region grows if necessary, but it never shrinks. COEXPSIZE (2000) The size, in words, of each co-expression block. MSTKSIZE (10000) The size, in words, of the main interpreter stack. STATSIZE (20480) The size, in bytes, of the static region in which co- expression blocks are allocated. If co-expressions are not implemented, the default size is 1024. STATINCR The size of the increment used when the static region is expanded. The default increment is one-fourth of the initial size of the static region.Printed 12/29/89Icon Project - 1/1/1990 - IPD109 3ICONT(1) UNIX Programmer's Manual ICONT(1) QLSIZE (5000) The size, in bytes, of the region used for pointers to strings during garbage collection (fixed-regions imple- mentations only). MEMMON The name of the output file for memory monitoring.FILES icont Icon command processor iconx Icon executorSEE ALSO The Icon Programming Language, Ralph E. Griswold and Madge T. Griswold, Prentice-Hall Inc., Englewood Cliffs, New Jer- sey, 1983. Version 8 of Icon, Ralph E. Griswold, TR 90-1, Department of Computer Science, The University of Arizona, 1990. m4(1), iconpi(1), iconvt(1)ICONT(1) UNIX Programmer's Manual ICONT(1)NAME icont - process Icon programsSYNOPSIS icont [ option ... ] file ... [ -x arg ... ]DESCRIPTION The program icont is a command processor for running Version 8 Icon programs. Used in its simplest form, it produces a file suitable for interpretation by the Icon interpreter. Processing consists of two phases: translation and linking. During translation, each Icon source file is translated into an intermediate language called ucode; during linking, the one or more ucode files are combined and a single icode file is produced. Unless the -o option is specified, the name of the resulting icode file is formed by deleting the suffix of the first input file named on the command line. If the -x argument is used, the file is automatically executed by the interpreter and any arguments following the -x are passed as execution arguments to the Icon program itself. Files whose names end in .icn are assumed to be Icon source programs. The .icn suffix may be omitted; it will be sup- plied automatically. These programs are translated, and the intermediate code is left in two ucode files of the same name with .u1 and .u2 substituted for .icn. The ucode files normally are deleted when icont completes. Files whose names end in .u1 are assumed to refer to ucode files from a previous translation; these files and the corresponding .u2 files are included in the linking phase after any .icn files have been translated. The suffix .u can be used in place of .u1; in this case the 1 is supplied automatically. A .u1 or .u2 file that is explicitly named is not deleted. Icon source programs may be read from standard input. The argu- ment - signifies the use of standard input as a source file. In this case, the ucode files are named stdin.u1 and stdin.u2 and the icode file is named stdin. The following options are recognized by icont: -c Suppress the linking phase. The ucode code files are not deleted. -m Preprocess each .icn source file with the m4(1) macro processor before translation. -o output Name the icode file output. -s Suppress informative messages from the translator and linker. Normally, both informative messages and error messages are sent to standard error output. -t Arrange for &trace to have an initial value of -1 whenPrinted 12/29/89Icon Project - 1/1/1990 - IPD109 1ICONT(1) UNIX Programmer's Manual ICONT(1) the program is executed. Normally, &trace has an ini- tial value of 0. -u Issue warning messages for undeclared identifiers in the program. The warnings are issued during the linking phase. Icon has several tables related to the translation and link- ing of programs. These tables are large enough for most programs, but their sizes can be changed, if necessary, by the -S option. This option has the form -S[cfgilnrstCFL]n, where the letter following the S specifies the table and n is the number of storage units to allocate for the table. The tables and their default sizes are: c constant table 100 f field table 100 g global symbol table 200 i identifier table 500 l local symbol table 100 n line number space 1000 r field table for records 100 s string space 20000 t tree space 15000 C code buffer 15000 F file names 10 L labels 500 The units depend on the table involved, but the default values can be used as a general guide for appropriate set- tings of -S options without knowing the units. The environment variable IPATH controls the location of files specified in link directives. The value of IPATH should be a blank-separated string of the form p1 p2 ... pn where the pi name directories. Each directory is searched in turn to locate files named in link directives. The default value for IPATH is . , that is, the current direc- tory. The current path is always searched first, regardless of the value of IPATH. The icode file produced by the Icon linker is executable. For example, the command icont hello.icn produces a file named hello that can be run by the command hello Arguments can be passed to the Icon program by following the program name with the arguments. Any such arguments are passed to the main procedure as a list of strings.Printed 12/29/89Icon Project - 1/1/1990 - IPD109 2ICONT(1) UNIX Programmer's Manual ICONT(1) The location of iconx, the executor for icode files, is built into an icode file when it is produced. This location can be overridden by setting the environment variable ICONX as described below. If ICONX is not set and iconx is not found on the built-in path, PATH is searched for it. When an Icon program is executed, several environment vari- ables are examined to determine certain execution parame- ters. Expect for ICONX, NOERRBUF, and ICONCORE, the values assigned to these variables should be numbers. The vari- ables that affect execution and the interpretations of their values follow. Numbers in parentheses are the default values. ICONX If this environment variable is set, it specifies the location of iconx to use to execute an icode file. TRACE Initialize the value of &trace. If this variable has a value, it overrides the translation-time -t option. NOERRBUF By default, &errout is buffered. If this variable is set, &errout is not buffered. ICONCORE If set, a core dump is produced for error termination. STRSIZE (65000) The initial size of the string space, in bytes. The string space grows if necessary, but it never shrinks. HEAPSIZE (65000) The initial size of the allocated block region, in bytes. The block region grows if necessary, but it never shrinks. COEXPSIZE (2000) The size, in words, of each co-expression block. MSTKSIZE (10000) The size, in words, of the main interpreter stack. STATSIZE (20480) The size, in bytes, of the static region in which co- expression blocks are allocated. If co-expressions are not implemented, the default size is 1024. STATINCR The size of the increment used when the static region is expanded. The default increment is one-fourth of the initial size of the static region.Printed 12/29/89Icon Project - 1/1/1990 - IPD109 3ICONT(1) UNIX Programmer's Manual ICONT(1) QLSIZE (5000) The size, in bytes, of the region used for pointers to strings during garbage collection (fixed-regions imple- mentations only). MEMMON The name of the output file for memory monitoring.FILES icont Icon command processor iconx Icon executorSEE ALSO The Icon Programming Language, Ralph E. Griswold and Madge T. Griswold, Prentice-Hall Inc., Englewood Cliffs, New Jer- sey, 1983. Version 8 of Icon, Ralph E. Griswold, TR 90-1, Department of Computer Science, The University of Arizona, 1990. m4(1), iconpi(1), iconvt(1) :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:bench Folder:concord.icn
############################################################################## Name: concord.icn## Title: Produce concordance## Author: Ralph E. Griswold## Date: December 22, 1989############################################################################### This program produces a simple concordance from standard input to standard# output. Words less than three characters long are ignored.## There are two options:## -l n set maximum line length to n (default 72), starts new line# -w n set maximum width for word to n (default 15), truncates## There are lots of possibilities for improving this program and adding# functionality to it. For example, a list of words to be ignored could be# provided. The formatting could be made more flexible, and so on.############################################################################### Note that the program is organized to make it easy (via item()) to# handle other kinds of tabulations.############################################################################### Links: options, post#############################################################################link options, postglobal uses, colmax, namewidth, linenoprocedure main(args) local opts, uselist, name, line Init__("concord") opts := options(args, "l+w+") # process options colmax := \opts["l"] | 72 namewidth := \opts["w"] | 15 uses := table("") lineno := 0 every tabulate(item(), lineno) # tabulate all the citations uselist := sort(uses, 3) # sort by uses while name := get(uselist) do format(left(name, namewidth) || get(uselist)) Term__()end# Add line number to citations for name. If it already has been cited, # add (or increment) the number of citations.#procedure tabulate(name, lineno) local new, count, number lineno := string(lineno) new := "" uses[name] ? { while new ||:= tab(upto(&digits)) do { number := tab(many(&digits)) new ||:= number } if /number | (number ~== lineno) then uses[name] ||:= lineno || ", " # new line number else { if ="(" then count := tab(upto(')')) else count := 1 uses[name] := new || "(" || count + 1 || "), " } }end# Format the output, breaking long lines as necessary.#procedure format(line) local i while *line > colmax + 2 do { i := colmax + 2 until line[i -:= 1] == " " # back off to break point write(line[1:i]) line := repl(" ", namewidth) || line[i + 1:0] } write(line[1:-2])end# Get an item. Different kinds of concordances can be obtained by# modifying this procedure.#procedure item() local i, word, line while line := read() do { lineno +:= 1 write(right(lineno, 6), " ", line) line := map(line) # fold to lowercase i := 1 line ? { while tab(upto(&letters)) do { word := tab(many(&letters)) if *word >= 3 then suspend word # skip short words } } }end :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:bench Folder:concord.std
Icon Version 8.0. February 14, 1990megaron.cs.arizona.eduUNIXASCIIco-expressionsdirect executionenvironment variableserror trace backexecutable imagesexpandable regionsexternal functionslarge integersmath functionsmemory monitoringpipesstring invocationsystem functionregionsstatic 20480string 65024block 65024*** Benchmarking with output *** 1 2 3 ICONT(1) UNIX Programmer's Manual ICONT(1) 4 5 6 NAME 7 icont - process Icon programs 8 9 SYNOPSIS 10 icont [ option ... ] file ... [ -x arg ... ] 11 12 DESCRIPTION 13 The program icont is a command processor for running Version 14 8 Icon programs. Used in its simplest form, it produces a 15 file suitable for interpretation by the Icon interpreter. 16 Processing consists of two phases: translation and linking. 17 During translation, each Icon source file is translated into 18 an intermediate language called ucode; during linking, the 19 one or more ucode files are combined and a single icode file 20 is produced. Unless the -o option is specified, the name of 21 the resulting icode file is formed by deleting the suffix of 22 the first input file named on the command line. If the -x 23 argument is used, the file is automatically executed by the 24 interpreter and any arguments following the -x are passed as 25 execution arguments to the Icon program itself. 26 27 Files whose names end in .icn are assumed to be Icon source 28 programs. The .icn suffix may be omitted; it will be sup- 29 plied automatically. These programs are translated, and the 30 intermediate code is left in two ucode files of the same 31 name with .u1 and .u2 substituted for .icn. The ucode files 32 normally are deleted when icont completes. Files whose 33 names end in .u1 are assumed to refer to ucode files from a 34 previous translation; these files and the corresponding .u2 35 files are included in the linking phase after any .icn files 36 have been translated. The suffix .u can be used in place of 37 .u1; in this case the 1 is supplied automatically. A .u1 or 38 .u2 file that is explicitly named is not deleted. Icon 39 source programs may be read from standard input. The argu- 40 ment - signifies the use of standard input as a source file. 41 In this case, the ucode files are named stdin.u1 and 42 stdin.u2 and the icode file is named stdin. 43 44 The following options are recognized by icont: 45 46 -c Suppress the linking phase. The ucode code files are 47 not deleted. 48 49 -m Preprocess each .icn source file with the m4(1) macro 50 processor before translation. 51 52 -o output 53 Name the icode file output. 54 55 -s Suppress informative messages from the translator and 56 linker. Normally, both informative messages and error 57 messages are sent to standard error output. 58 59 -t Arrange for &trace to have an initial value of -1 when 60 61 62 Printed 12/29/89Icon Project - 1/1/1990 - IPD109 1 63 64 65 66 67 68 69 ICONT(1) UNIX Programmer's Manual ICONT(1) 70 71 72 the program is executed. Normally, &trace has an ini- 73 tial value of 0. 74 75 -u Issue warning messages for undeclared identifiers in the 76 program. The warnings are issued during the linking 77 phase. 78 79 Icon has several tables related to the translation and link- 80 ing of programs. These tables are large enough for most 81 programs, but their sizes can be changed, if necessary, by 82 the -S option. This option has the form -S[cfgilnrstCFL]n, 83 where the letter following the S specifies the table and n 84 is the number of storage units to allocate for the table. 85 The tables and their default sizes are: 86 87 c constant table 100 88 f field table 100 89 g global symbol table 200 90 i identifier table 500 91 l local symbol table 100 92 n line number space 1000 93 r field table for records 100 94 s string space 20000 95 t tree space 15000 96 C code buffer 15000 97 F file names 10 98 L labels 500 99 100 The units depend on the table involved, but the default 101 values can be used as a general guide for appropriate set- 102 tings of -S options without knowing the units. 103 104 The environment variable IPATH controls the location of 105 files specified in link directives. The value of IPATH 106 should be a blank-separated string of the form p1 p2 ... pn 107 where the pi name directories. Each directory is searched 108 in turn to locate files named in link directives. The 109 default value for IPATH is . , that is, the current direc- 110 tory. The current path is always searched first, regardless 111 of the value of IPATH. 112 113 The icode file produced by the Icon linker is executable. 114 For example, the command 115 116 icont hello.icn 117 118 produces a file named hello that can be run by the command 119 120 hello 121 122 123 Arguments can be passed to the Icon program by following the 124 program name with the arguments. Any such arguments are 125 passed to the main procedure as a list of strings. 126 127 128 Printed 12/29/89Icon Project - 1/1/1990 - IPD109 2 129 130 131 132 133 134 135 ICONT(1) UNIX Programmer's Manual ICONT(1) 136 137 138 The location of iconx, the executor for icode files, is 139 built into an icode file when it is produced. This location 140 can be overridden by setting the environment variable ICONX 141 as described below. If ICONX is not set and iconx is not 142 found on the built-in path, PATH is searched for it. 143 144 When an Icon program is executed, several environment vari- 145 ables are examined to determine certain execution parame- 146 ters. Expect for ICONX, NOERRBUF, and ICONCORE, the values 147 assigned to these variables should be numbers. The vari- 148 ables that affect execution and the interpretations of their 149 values follow. Numbers in parentheses are the default 150 values. 151 152 ICONX 153 If this environment variable is set, it specifies the 154 location of iconx to use to execute an icode file. 155 156 TRACE 157 Initialize the value of &trace. If this variable has a 158 value, it overrides the translation-time -t option. 159 160 NOERRBUF 161 By default, &errout is buffered. If this variable is 162 set, &errout is not buffered. 163 164 ICONCORE 165 If set, a core dump is produced for error termination. 166 167 STRSIZE (65000) 168 The initial size of the string space, in bytes. The 169 string space grows if necessary, but it never shrinks. 170 171 HEAPSIZE (65000) 172 The initial size of the allocated block region, in 173 bytes. The block region grows if necessary, but it 174 never shrinks. 175 176 COEXPSIZE (2000) 177 The size, in words, of each co-expression block. 178 179 MSTKSIZE (10000) 180 The size, in words, of the main interpreter stack. 181 182 STATSIZE (20480) 183 The size, in bytes, of the static region in which co- 184 expression blocks are allocated. If co-expressions are 185 not implemented, the default size is 1024. 186 187 STATINCR 188 The size of the increment used when the static region is 189 expanded. The default increment is one-fourth of the 190 initial size of the static region. 191 192 193 194 Printed 12/29/89Icon Project - 1/1/1990 - IPD109 3 195 196 197 198 199 200 201 ICONT(1) UNIX Programmer's Manual ICONT(1) 202 203 204 QLSIZE (5000) 205 The size, in bytes, of the region used for pointers to 206 strings during garbage collection (fixed-regions imple- 207 mentations only). 208 209 MEMMON 210 The name of the output file for memory monitoring. 211 212 FILES 213 icont Icon command processor 214 iconx Icon executor 215 216 SEE ALSO 217 The Icon Programming Language, Ralph E. Griswold and Madge 218 T. Griswold, Prentice-Hall Inc., Englewood Cliffs, New Jer- 219 sey, 1983. 220 221 Version 8 of Icon, Ralph E. Griswold, TR 90-1, Department of 222 Computer Science, The University of Arizona, 1990. 223 224 m4(1), iconpi(1), iconvt(1) 225 226 ICONT(1) UNIX Programmer's Manual ICONT(1) 227 228 229 NAME 230 icont - process Icon programs 231 232 SYNOPSIS 233 icont [ option ... ] file ... [ -x arg ... ] 234 235 DESCRIPTION 236 The program icont is a command processor for running Version 237 8 Icon programs. Used in its simplest form, it produces a 238 file suitable for interpretation by the Icon interpreter. 239 Processing consists of two phases: translation and linking. 240 During translation, each Icon source file is translated into 241 an intermediate language called ucode; during linking, the 242 one or more ucode files are combined and a single icode file 243 is produced. Unless the -o option is specified, the name of 244 the resulting icode file is formed by deleting the suffix of 245 the first input file named on the command line. If the -x 246 argument is used, the file is automatically executed by the 247 interpreter and any arguments following the -x are passed as 248 execution arguments to the Icon program itself. 249 250 Files whose names end in .icn are assumed to be Icon source 251 programs. The .icn suffix may be omitted; it will be sup- 252 plied automatically. These programs are translated, and the 253 intermediate code is left in two ucode files of the same 254 name with .u1 and .u2 substituted for .icn. The ucode files 255 normally are deleted when icont completes. Files whose 256 names end in .u1 are assumed to refer to ucode files from a 257 previous translation; these files and the corresponding .u2 258 files are included in the linking phase after any .icn files 259 have been translated. The suffix .u can be used in place of 260 .u1; in this case the 1 is supplied automatically. A .u1 or 261 .u2 file that is explicitly named is not deleted. Icon 262 source programs may be read from standard input. The argu- 263 ment - signifies the use of standard input as a source file. 264 In this case, the ucode files are named stdin.u1 and 265 stdin.u2 and the icode file is named stdin. 266 267 The following options are recognized by icont: 268 269 -c Suppress the linking phase. The ucode code files are 270 not deleted. 271 272 -m Preprocess each .icn source file with the m4(1) macro 273 processor before translation. 274 275 -o output 276 Name the icode file output. 277 278 -s Suppress informative messages from the translator and 279 linker. Normally, both informative messages and error 280 messages are sent to standard error output. 281 282 -t Arrange for &trace to have an initial value of -1 when 283 284 285 Printed 12/29/89Icon Project - 1/1/1990 - IPD109 1 286 287 288 289 290 291 292 ICONT(1) UNIX Programmer's Manual ICONT(1) 293 294 295 the program is executed. Normally, &trace has an ini- 296 tial value of 0. 297 298 -u Issue warning messages for undeclared identifiers in the 299 program. The warnings are issued during the linking 300 phase. 301 302 Icon has several tables related to the translation and link- 303 ing of programs. These tables are large enough for most 304 programs, but their sizes can be changed, if necessary, by 305 the -S option. This option has the form -S[cfgilnrstCFL]n, 306 where the letter following the S specifies the table and n 307 is the number of storage units to allocate for the table. 308 The tables and their default sizes are: 309 310 c constant table 100 311 f field table 100 312 g global symbol table 200 313 i identifier table 500 314 l local symbol table 100 315 n line number space 1000 316 r field table for records 100 317 s string space 20000 318 t tree space 15000 319 C code buffer 15000 320 F file names 10 321 L labels 500 322 323 The units depend on the table involved, but the default 324 values can be used as a general guide for appropriate set- 325 tings of -S options without knowing the units. 326 327 The environment variable IPATH controls the location of 328 files specified in link directives. The value of IPATH 329 should be a blank-separated string of the form p1 p2 ... pn 330 where the pi name directories. Each directory is searched 331 in turn to locate files named in link directives. The 332 default value for IPATH is . , that is, the current direc- 333 tory. The current path is always searched first, regardless 334 of the value of IPATH. 335 336 The icode file produced by the Icon linker is executable. 337 For example, the command 338 339 icont hello.icn 340 341 produces a file named hello that can be run by the command 342 343 hello 344 345 346 Arguments can be passed to the Icon program by following the 347 program name with th
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:bench Folder:concor
Version 8 Icon Benchmark ReportComputer manufacturer: _____________ model: _____________Processor: _____________Operating system: _____________ version:_____________C compiler: _____________ version:_____________Optimization used: _____________Timing results: concord.icn:_____________ deal.icn: _____________ ipxref.icn:_____________ queens.icn:_____________ rsg.icn: _____________Comments:Send this form, together with the benchmark output to: Icon Project Department of Computer Science Gould-Simpson Building The University of Arizona Tucson, AZ 85721 U.S.A. (602) 621-4049 icon-project@cs.arizona.edu (Internet) ... {uunet, allegra, noao}!arizona!icon-project (uucp)IPD116 - 1 - February 27, 1990 :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:bench Folder:ipxref.dat
############################################################################## Name: ipxref.icn## Title: Produce cross reference for Icon program## Author: Allan J. Anderson## Date: June 10, 1988############################################################################## # This program cross-references Icon programs. It lists the# occurrences of each variable by line number. Variables are listed# by procedure or separately as globals. The options specify the# formatting of the output and whether or not to cross-reference# quoted strings and non-alphanumerics. Variables that are followed# by a left parenthesis are listed with an asterisk following the# name. If a file is not specified, then standard input is cross-# referenced.# # Options: The following options change the format defaults:# # -c n The column width per line number. The default is 4# columns wide.# # -l n The starting column (i.e. left margin) of the line# numbers. The default is column 40.# # -w n The column width of the whole output line. The default# is 80 columns wide.# # Normally only alphanumerics are cross-referenced. These# options expand what is considered:# # -q Include quoted strings.# # -x Include all non-alphanumerics.# # Note: This program assumes the subject file is a valid Icon pro-# gram. For example, quotes are expected to be matched.# ############################################################################## Bugs:## In some situations, the output is not properly formatted.############################################################################### Links: options, post#############################################################################link options, postglobal resword, linenum, letters, alphas, var, buffer, qflag, infile, xflagglobal inmaxcol, inlmarg, inchunk, localvar, linrecord procrec(pname,begline,lastline)procedure main(args) local word, w2, p, prec, i, L, ln, switches, nfile Init__("ipxref") resword := ["break","by","case","default","do","dynamic","else","end", "every","fail","global","if","initial","link", "local","next","not", "of","procedure", "record","repeat","return","static","suspend","then", "to","until","while"] linenum := 0 var := table() # var[variable[proc]] is list of line numbers prec := [] # list of procedure records localvar := [] # list of local variables of current routine buffer := [] # a put-back buffer for getword proc := "global" letters := &letters ++ '_' alphas := letters ++ &digits switches := options(args,"qxw+l+c+") if \switches["q"] then qflag := 1 if \switches["x"] then xflag := 1 inmaxcol := \switches["w"] inlmarg := \switches["l"] inchunk := \switches["c"] infile := open(args[1],"r") # could use some checking while word := getword() do if word == "link" then { buffer := [] lin := "" next } else if word == "procedure" then { put(prec,procrec("",linenum,0)) proc := getword() | break p := pull(prec) p.pname := proc put(prec,p) } else if word == ("global" | "link" | "record") then { word := getword() | break addword(word,"global",linenum) while (w2 := getword()) == "," do { if word == !resword then break word := getword() | break addword(word,"global",linenum) } put(buffer,w2) } else if word == ("local" | "dynamic" | "static") then { word := getword() | break put(localvar,word) addword(word,proc,linenum) while (w2 := getword()) == "," do { if word == !resword then break word := getword() | break put(localvar, addword(word,proc,linenum) } put(buffer,w2) } else if word == "end" then { proc := "global" localvar := [] p := pull(prec) p.lastline := linenum put(prec,p) } else if word == !resword then next else { ln := linenum if (w2 := getword()) == "(" then word ||:= " *" # special mark for procedures else put(buffer,w2) # put back w2 addword(word,proc,ln) } every write(!format(var)) write("\n\nprocedures:\tlines:\n") L := [] every p := !prec do put(L,left(p.pname,16," ") || p.begline || "-" || p.lastline) every write(!sort(L)) Term__()endprocedure addword(word,proc,lineno) if any(letters,word) | \xflag then { /var[word] := table() if /var[word]["global"] | (word == !\localvar) then { /(var[word])[proc] := [word,proc] put((var[word])[proc],lineno) } else { /var[word]["global"] := [word,"global"] put((var[word])["global"],lineno) } }endprocedure getword() local j, c static i, nonwhite initial nonwhite := ~' \t\n' repeat { if *buffer > 0 then return get(buffer) if /lin | i = *lin + 1 then if lin := read(infile) then { i := 1 linenum +:= 1 } else fail if i := upto(nonwhite,lin,i) then { # skip white space j := i if lin[i] == ("'" | "\"") then { # don't xref quoted words if /qflag then { c := lin[i] i +:= 1 repeat if i := upto(c ++ '\\',lin,i) + 1 then if lin[i - 1] == c then break else i +:= 1 else { i := 1 linenum +:= 1 lin := read(infile) | fail } } else i +:= 1 } else if lin[i] == "#" then { # don't xref comments; get next line i := *lin + 1 } else if i := many(alphas,lin,i) then return lin[j:i] else { i +:= 1 return lin[i - 1] } } else i := *lin + 1 } # repeatendprocedure format(T) local V, block, n, L, lin, maxcol, lmargin, chunk, col initial { maxcol := \inmaxcol | 80 lmargin := \inlmarg | 40 chunk := \inchunk | 4 } L := [] col := lmargin every V := !T do every block := !V do { lin := left(block[1],16," ") || left(block[2],lmargin - 16," ") every lin ||:= center(block[3 to *block],chunk," ") do { col +:= chunk if col >= maxcol - chunk then { lin ||:= "\n\t\t\t\t\t" col := lmargin } } if col = lmargin then lin := lin[1:-6] # came out exactly even put(L,lin) col := lmargin } L := sort(L) push(L,"variable\tprocedure\t\tline numbers\n") return Lend :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:bench Folder:ipxref.icn
############################################################################## Name: ipxref.icn## Title: Produce crossce for Icon program## Author: Allan J. Anderson## Date: June 10, 1988############################################################################## # This program cross-references Icon programs. It lists the# occurrences of each variable by line number. Variables are listed# by procedure or separately as globals. The options specify the# formatting of the output and whether or not to cross-reference# quoted strings and non-alphanumerics. Variables that are followed# by a left parenthesis are listed with an asterisk following the# name. If a file is not specified, then standard input is cross-# referenced.# # Options: The following options change the format defaults:# # -c n The column width per line number. The default is 4# columns wide.# # -l n The starting column (i.e. left margin) of the line# numbers. The default is column 40.# # -w n The column width of the whole output line. The default# is 80 columns wide.# # Normally only alphanumerics are cross-referenced. These# options expand what is considered:# # -q Include quoted strings.# # -x Include all non-alphanumerics.# # Note: This program assumes the subject file is a valid Icon pro-# gram. For example, quotes are expected to be matched.# ############################################################################## Bugs:## In some situations, the output is not properly formatted.############################################################################### Links: options, post#############################################################################link options, postglobal resword, linenum, letters, alphas, var, buffer, qflag, infile, xflagglobal inmaxcol, inlmarg, inchunk, localvar, linrecord procrec(pname,begline,lastline)procedure main(args) local word, w2, p, prec, i, L, ln, switches, nfile Init__("ipxref") resword := ["break","by","case","default","do","dynamic","else","end", "every","fail","global","if","initial","link", "local","next","not", "of","procedure", "record","repeat","return","static","suspend","then", "to","until","while"] linenum := 0 var := table() # var[variable[proc]] is list of line numbers prec := [] # list of procedure records localvar := [] # list of local variables of current routine buffer := [] # a put-back buffer for getword proc := "global" letters := &letters ++ '_' alphas := letters ++ &digits switches := options(args,"qxw+l+c+") if \switches["q"] then qflag := 1 if \switches["x"] then xflag := 1 inmaxcol := \switches["w"] inlmarg := \switches["l"] inchunk := \switches["c"] infile := open(args[1],"r") # could use some checking while word := getword() do if word == "link" then { buffer := [] lin := "" next } else if word == "procedure" then { put(prec,procrec("",linenum,0)) proc := getword() | break p := pull(prec) p.pname := proc put(prec,p) } else if word == ("global" | "link" | "record") then { word := getword() | break addword(word,"global",linenum) while (w2 := getword()) == "," do { if word == !resword then break word := getword() | break addword(word,"global",linenum) } put(buffer,w2) } else if word == ("local" | "dynamic" | "static") then { word := getword() | break put(localvar,word) addword(word,proc,linenum) while (w2 := getword()) == "," do { if word == !resword then break word := getword() | break put(localvar,word) addword(word,proc,linenum) } put(buffer,w2) } else if word == "end" then { proc := "global" localvar := [] p := pull(prec) p.lastline := linenum put(prec,p) } else if word == !resword then next else { ln := linenum if (w2 := getword()) == "(" then word ||:= " *" # special mark for procedures else put(buffer,w2) # put back w2 addword(word,proc,ln) } every write(!format(var)) write("\n\nprocedures:\tlines:\n") L := [] every p := !prec do put(L,left(p.pname,16," ") || p.begline || "-" || p.lastline) every write(!sort(L)) Term__()endprocedure addword(word,proc,lineno) if any(letters,word) | \xflag then { /var[word] := table() if /var[word]["global"] | (word == !\localvar) then { /(var[word])[proc] := [word,proc] put((var[word])[proc],lineno) } else { /var[word]["global"] := [word,"global"] put((var[word])["global"],lineno) } }endprocedure getword() local j, c static i, nonwhite initial nonwhite := ~' \t\n' repeat { if *buffer > 0 then return get(buffer) if /lin | i = *lin + 1 then if lin := read(infile) then { i := 1 linenum +:= 1 } else fail if i := upto(nonwhite,lin,i) then { # skip white space j := i if lin[i] == ("'" | "\"") then { # don't xref quoted words if /qflag then { c := lin[i] i +:= 1 repeat if i := upto(c ++ '\\',lin,i) + 1 then if lin[i - 1] == c then break else i +:= 1 else { i := 1 linenum +:= 1 lin := read(infile) | fail } } else i +:= 1 } else if lin[i] == "#" then { # don't xref comments; get next line i := *lin + 1 } else if i := many(alphas,lin,i) then return lin[j:i] else { i +:= 1 return lin[i - 1] } } else i := *lin + 1 } # repeatendprocedure format(T) local V, block, n, L, lin, maxcol, lmargin, chunk, col initial { maxcol := \inmaxcol | 80 lmargin := \inlmarg | 40 chunk := \inchunk | 4 } L := [] col := lmargin every V := !T do every block := !V do { lin := left(block[1],16," ") || left(block[2],lmargin - 16," ") every lin ||:= center(block[3 to *block],chunk," ") do { col +:= chunk if col >= maxcol - chunk then { lin ||:= "\n\t\t\t\t\t" col := lmargin } } if col = lmargin then lin := lin[1:-6] # came out exactly even put(L,lin) col := lmargin } L := sort(L) push(L,"variable\tprocedure\t\tline numbers\n") return Lend :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:bench Folder:ipxref.std
Icon Version 8.0x. December 12, 1989.megaron.arizona.eduUNIXASCIIco-expressionsdirect executionenvironment variableserror trace backexpandable regionsexternal functionsmath functionsmemory monitoringoverflow checkingpipesstring invocationsystem functionregionsstatic 60480string 65024block 65024*** Benchmarking with output ***variable procedure line numbersInit__ * main 66 L format 214 220 233 236 236 237 238 L main 64 144 146 147 T format 213 222 Term__ * main 149 V format 214 222 223 addword * main 105 109 116 121 140 alphas global 57 79 201 any * addword 154 args main 62 81 88 begline global 60 146 block format 214 223 224 224 225 225 buffer global 57 76 92 111 123 139 173 173 c getword 168 184 187 188 center * format 225 chunk format 214 218 225 226 227 col format 214 221 226 227 229 232 234 digits main 79 format * main 142 get * getword 173 getword * main 90 98 104 106 108 114 117 119 136 i getword 169 174 176 180 180 181 182 184 185 187 187 188 189 191 196 198 199 201 201 202 204 205 209 i main 64 inchunk global 58 87 218 infile global 57 88 175 193 inlmarg global 58 86 217 inmaxcol global 58 85 216 j getword 168 181 202 lastline global 60 129 146 left * format 224 224 left * main 146 letters global 57 78 78 79 154 lin format 214 224 225 228 232 232 233 lin global 58 93 174 174 175 180 182 184 187 188 193 198 199 201 202 205 209 lineno addword 153 158 162 linenum global 57 72 97 105 109 116 121 129 135 177 192 lmargin format 214 217 221 224 229 232 234 ln main 64 135 140 localvar global 58 75 115 120 127 156 many * getword 201 maxcol format 214 216 227 n format 214 nfile main 64 nonwhite getword 169 170 180 open * main 88 options * main 81 p main 64 99 100 101 128 129 130 145 146 146 146 pname global 60 100 146 prec main 64 74 97 99 101 128 130 145 proc addword 153 157 157 158 proc main 77 98 100 116 121 126 140 procrec global 60 procrec * main 97 pull * main 99 128 push * format 237 put * addword 158 162 put * format 233 put * main 97 101 111 115 120 123 130 139 146 qflag global 57 83 183 read * getword 175 193 resword global 57 68 107 118 132 sort * format 236 sort * main 147 switches main 64 81 83 84 85 86 87 table * addword 155 table * main 73 upto * getword 180 187 var global 57 73 142 155 156 157 158 161 162 w2 main 64 106 111 117 123 136 139 word addword 153 154 155 156 156 157 157 158 161 161 162 word main 64 90 91 96 103 104 105 107 108 109 113 114 115 116 118 119 120 121 125 132 137 140 write * main 142 143 147 xflag global 57 84 154 procedures: lines:addword 153-165format 213-239getword 167-211main 62-151ipxref elapsed time = 5366regionsstatic 60480string 65024block 65024storagestatic 60480string 27113block 31992collectionstotal 2static 0string 0block 2 :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:bench Folder:Makefile
what ƒ ### What do you want to make?benchmark ƒ Translate post options shuffle Compile concord deal ipxref queens rsg Run search elapsed ≈.outtranslate ƒ Translate post options shufflecompile ƒ Compile concord deal ipxref queens rsgrun ƒ Runrerun ƒ ReRuncheck ƒ search elapsed ≈.outClean ƒ delete ≈.out ≈.u[12] concord deal ipxref queens rsg :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:bench Folder:options.icn
############################################################################## Name: options.icn## Title: Get command-line options## Authors: Robert J. Alexander, June 10, 1988# Gregg M. Townsend, November 9, 1989############################################################################## # options(arg,optstring) -- Get command line options.# # This procedure analyzes the -options on the command line# invoking an Icon program. The inputs are:# # arg the argument list as passed to the main procedure.## optstring a string of allowable option letters. If a# letter is followed by ":" the corresponding# option is assumed to be followed by a string of# data, optionally separated from the letter by# space. If instead of ":" the letter is followed# by a "+", the parameter will converted to an# integer; if a ".", converted to a real. If opt-# string is omitted any letter is assumed to be# valid and require no data.# # It returns a table containing the options that were specified.# The keys are the specified option letters. The assigned values are# the data words following the options, if any, or 1 if the option# has no data. The table's default value is &null.# # If an error is detected, stop() is called with an appropriate# error message.## Options may be freely interspersed with non-option arguments.# An argument of "-" is treated as a non-option. The special argument# "--" terminates option processing. Non-option arguments are returned# in the original argument list for interpretation by the caller.# ############################################################################procedure options(arg,optstring) local x,i,c,otab,flist,o,p /optstring := string(&letters) otab := table() flist := [] while x := get(arg) do x ? { if ="-" & not pos(0) then { if ="-" & pos(0) then break while c := move(1) do if i := find(c,optstring) + 1 then otab[c] := if any(':+.',o := optstring[i]) then { p := "" ~== tab(0) | get(arg) | stop("No parameter following -",c) case o of { ":": p "+": integer(p) | stop("-",c," needs numeric parameter") ".": real(p) | stop("-",c," needs numeric parameter") } } else 1 else stop("Unrecognized option: -",c) } else put(flist,x) } while push(arg,pull(flist)) return otabend :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:bench Folder:post.icn
################################################################### Support procedures for Icon benchmarking.#################################################################### The code to be times is bracketed by calls to Init__(name)# and Term__(), where name is used for tagging the results.# The typical usage is:## procedure main()# [declarations]# Init__(name)# .# .# .# Term__()# end## If the environment variable OUTPUT is set, program output is# not suppressed.##################################################################global Save__, Saves__, Name__# List information before running.#procedure Init__(prog) Name__ := prog # program name Signature__() # initial information Regions__() Time__() if getenv("OUTPUT") then { # if OUTPUT is set, allow output write("*** Benchmarking with output ***") return } Save__ := write # turn off output Saves__ := writes write := writes := 1 returnend# List information at termination.procedure Term__() if not getenv("OUTPUT") then { # if OUTPUT is not set, restore output write := Save__ writes := Saves__ } # final information write(Name__," elapsed time = ",Time__()) Regions__() Storage__() Collections__() returnend# List garbage collections performed.#procedure Collections__() static labels local collections initial labels := ["total","static","string","block"] collections := [] every put(collections,&collections) write("collections") every i := 1 to *labels do write(labels[i],right(collections[i],8)) returnend# List region sizes.#procedure Regions__() static labels local regions initial labels := ["static","string","block"] regions := [] every put(regions,®ions) write("regions") every i := 1 to *labels do write(labels[i],right(regions[i],8)) returnend# List relveant implementation information#procedure Signature__() write(&version) write(&host) every write(&features) returnend# List storage used.#procedure Storage__() static labels local storage initial labels := ["static","string","block"] storage := [] every put(storage,&storage) write("storage") every i := 1 to *labels do write(labels[i],right(storage[i],8)) returnend# List elapsed time.#procedure Time__() static lasttime initial lasttime := &time return &time - lasttimeend :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:bench Folder:queens.icn
############################################################################## Name: queens.icn## Title: Generate solutions to the n-queens problem## Author: Stephen B. Wampler## Date: June 10, 1988############################################################################## # This program displays the solutions to the non-attacking n-# queens problem: the ways in which n queens can be placed on an# n-by-n chessboard so that no queen can attack another. A positive# integer can be given as a command line argument to specify the# number of queens. For example,# # iconx queens -n8# # displays the solutions for 8 queens on an 8-by-8 chessboard. The# default value in the absence of an argument is 6. One solution# for six queens is:# # -------------------------# | | Q | | | | |# -------------------------# | | | | Q | | |# -------------------------# | | | | | | Q |# -------------------------# | Q | | | | | |# -------------------------# | | | Q | | | |# -------------------------# | | | | | Q | |# -------------------------# # Comments: There are many approaches to programming solutions to# the n-queens problem. This program is worth reading for# its programming techniques.# ############################################################################## Links: options, post#############################################################################link options, postglobal n, solutionprocedure main(args) local i, opts Init__() opts := options(args,"n+") n := \opts["n"] | 6 if n <= 0 then stop("-n needs a positive numeric parameter") solution := list(n) # ... and a list of column solutions write(n,"-Queens:") every q(1) # start by placing queen in first column Term__()end# q(c) - place a queen in column c.#procedure q(c) local r static up, down, rows initial { up := list(2*n-1,0) down := list(2*n-1,0) rows := list(n,0) } every 0 = rows[r := 1 to n] = up[n+r-c] = down[r+c-1] & rows[r] <- up[n+r-c] <- down[r+c-1] <- 1 do { solution[c] := r # record placement. if c = n then show() else q(c + 1) # try to place next queen. }end# show the solution on a chess board.#procedure show() static count, line, border initial { count := 0 line := repl("| ",n) || "|" border := repl("----",n) || "-" } write("solution: ", count+:=1) write(" ", border) every line[4*(!solution - 1) + 3] <- "Q" do { write(" ", line) write(" ", border) } write()end :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:bench Folder:queens.std
This directory contains programs and scripts for benchmarkingVersion 8 of Icon. The whole thing can be done with make benchm the Makefile in this directory and IPD115 for more information.Notes:In order for the benchmarks to be compared meaningfully to benchmarksfrom other computers, the Icon string and block region sizes mustbe 65,000 bytes (or close to that -- rounding sometimes occurs). Thisis the default value for the sizes of these regions. If you have othersizes set by default, change them for benchmarking. The output showsthe values used.The benchmarks normally are run with normal program output turned offto prevent the results from being affected by i/o factors. Output can beturned on by setting the environment variable OUTPUT. Timings with outputturned on generally cannot be compared meaningfully to benchmarks fromother computers.Benchmarking is contingent on Icon running properly. Output from benchmark-ing on a VAX 8650 under 4.3BSD is contained in the files *.std, and canbe used for comparison if there is any doubt. NOTE: The *.std files arenot included in all distributions of Icon because of their size. However,if Icon runs other programs properly, there should be no problem with thebenchmark programs. :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:bench Folder:Rerun
############################################################################## Name: rsg.icn## Title: Generate randomly selected sentences from a grammar## Author: Ralph E. Griswold## Date: June 10, 1988############################################################################## # This program generates randomly selected strings (``sen-# tences'') from a grammar specified by the user. Grammars are# basically context-free and resemble BNF in form, although there# are a number of extensions.# # The program works interactively, allowing the user to build,# test, modify, and save grammars. Input to rsg consists of various# kinds of specifications, which can be intermixed:# # Productions define nonterminal symbols in a syntax similar to# the rewriting rules of BNF with various alternatives consisting# of the concatenation of nonterminal and terminal symbols. Gen-# eration specifications cause the generation of a specified number# of sentences from the language defined by a given nonterminal# symbol. Grammar output specifications cause the definition of a# specified nonterminal or the entire current grammar to be written# to a given file. Source specifications cause subsequent input to# be read from a specified file.# # In addition, any line beginning with # is considered to be a# comment, while any line beginning with = causes the rest of that# line to be used subsequently as a prompt to the user whenever rsg# is ready for input (there normally is no prompt). A line consist-# ing of a single = stops prompting.# # Productions: Examples of productions are:# # <expr>::=<term>|<term>+<expr># <term>::=<elem>|<elem>*<term># <elem>::=x|y|z|(<expr>)# # Productions may occur in any order. The definition for a nonter-# minal symbol can be changed by specifying a new production for# it.# # There are a number of special devices to facilitate the defin-# ition of grammars, including eight predefined, built-in nontermi-# nal symbols:# symbol definition# <lb> <# <rb> ># <vb> |# <nl> newline# <> empty string# <&lcase> any single lowercase letter# <&ucase> any single uppercase letter# <&digit> any single digit# # In addition, if the string between a < and a > begins and ends# with a single quotation mark, it stands for any single character# between the quotation marks. For example,# # <'xyz'># # is equivalent to# # x|y|z# # Generation Specifications: A generation specification consists of# a nonterminal symbol followed by a nonnegative integer. An exam-# ple is# # <expr>10# # which specifies the generation of 10 <expr>s. If the integer is# omitted, it is assumed to be 1. Generated sentences are written# to standard output.# # Grammar Output Specifications: A grammar output specification# consists of a nonterminal symbol, followed by ->, followed by a# file name. Such a specification causes the current definition of# the nonterminal symbol to be written to the given file. If the# file is omitted, standard output is assumed. If the nonterminal# symbol is omitted, the entire grammar is written out. Thus,# # -># # causes the entire grammar to be written to standard output.# # Source Specifications: A source specification consists of @ fol-# lowed by a file name. Subsequent input is read from that file.# When an end of file is encountered, input reverts to the previous# file. Input files can be nested.# # Options: The following options are available:# # -s n Set the seed for random generation to n. The default# seed is 0.# # -l n Terminate generation if the number of symbols remaining# to be processed exceeds n. The default is limit is 1000.# # -t Trace the generation of sentences. Trace output goes to# standard error output.# # Diagnostics: Syntactically erroneous input lines are noted but# are otherwise ignored. Specifications for a file that cannot be# opened are noted and treated as erroneous.# # If an undefined nonterminal symbol is encountered during gen-# eration, an error message that identifies the undefined symbol is# produced, followed by the partial sentence generated to that# point. Exceeding the limit of symbols remaining to be generated# as specified by the -l option is handled similarly.# # Caveats: Generation may fail to terminate because of a loop in# the rewriting rules or, more seriously, because of the progres-# sive accumulation of nonterminal symbols. The latter problem can# be identified by using the -t option and controlled by using the# -l option. The problem often can be circumvented by duplicating# alternatives that lead to fewer rather than more nonterminal sym-# bols. For example, changing# # <term>::=<elem>|<elem>*<term># # to# # <term>::=<elem>|<elem>|<elem>*<term># # increases the probability of selecting <elem> from 1/2 to 2/3.# # There are many possible extensions to the program. One of the# most useful would be a way to specify the probability of select-# ing an alternative.# ############################################################################## Links: options, post#############################################################################link options, postglobal defs, ifile, in, limit, prompt, tswitchrecord nonterm(name)record charset(chars)procedure main(args) local line, plist, s, opts Init__() # procedures to try on input lines plist := [define,generate,grammar,source,comment,prompter,error] defs := table() # table of definitions defs["lb"] := [["<"]] # built-in definitions defs["rb"] := [[">"]] defs["vb"] := [["|"]] defs["nl"] := [["\n"]] defs[""] := [[""]] defs["&lcase"] := [[charset(&lcase)]] defs["&ucase"] := [[charset(&ucase)]] defs["&digit"] := [[charset(&digits)]] opts := options(args,"tl+s+") limit := \opts["l"] | 1000 tswitch := \opts["t"] &random := \opts["s"] ifile := [&input] # stack of input files prompt := "" while in := pop(ifile) do { # process all files repeat { if *prompt ~= 0 then writes(prompt) line := read(in) | break while line[-1] == "\\" do line := line[1:-1] || read(in) | break (!plist)(line) } close(in) } Term__()end# process alternatives#procedure alts(defn) local alist alist := [] defn ? while put(alist,syms(tab(upto('|') | 0))) do move(1) | break return alistend# look for comment#procedure comment(line) if line[1] == "#" then returnend# look for definition#procedure define(line) return line ? defs[(="<",tab(find(">::=")))] := (move(4),alts(tab(0)))end# define nonterminal#procedure defnon(sym) local chars, name if sym ? { ="'" & chars := cset(tab(-1)) & ="'" } then return charset(chars) else return nonterm(sym)end# note erroneous input line#procedure error(line) write("*** erroneous line: ",line) returnend# generate sentences#procedure gener(goal) local pending, symbol pending := [nonterm(goal)] while symbol := get(pending) do { if \tswitch then write(&errout,symimage(symbol),listimage(pending)) case type(symbol) of { "string": writes(symbol) "charset": writes(?symbol.chars) "nonterm": { pending := ?\defs[symbol.name] ||| pending | { write(&errout,"*** undefined nonterminal: <",symbol.name,">") break } if *pending > \limit then { write(&errout,"*** excessive symbols remaining") break } } } } write()end# look for generation specification#procedure generate(line) local goal, count if line ? { ="<" & goal := tab(upto('>')) \ 1 & move(1) & count := (pos(0) & 1) | integer(tab(0)) } then { every 1 to count do gener(goal) return } else failend# get right hand side of production#procedure getrhs(a) local rhs rhs := "" every rhs ||:= listimage(!a) || "|" return rhs[1:-1]end# look for request to write out grammar#procedure grammar(line) local file, out, name if line ? { name := tab(find("->")) & move(2) & file := tab(0) & out := if *file = 0 then &output else { open(file,"w") | { write(&errout,"*** cannot open ",file) fail } } } then { (*name = 0) | (name[1] == "<" & name[-1] == ">") | fail pwrite(name,out) if *file ~= 0 then close(out) return } else failend# produce image of list of grammar symbols#procedure listimage(a) local s, x s := "" every x := !a do s ||:= symimage(x) return send# look for new prompt symbol#procedure prompter(line) if line[1] == "=" then { prompt := line[2:0] return }end# write out grammar#procedure pwrite(name,ofile) local nt, a static builtin initial builtin := ["lb","rb","vb","nl","","&lcase","&ucase","&digit"] if *name = 0 then { a := sort(defs,3) while nt := get(a) do { if nt == !builtin then { get(a) next } write(ofile,"<",nt,">::=",getrhs(get(a))) } } else write(ofile,name,"::=",getrhs(\defs[name[2:-1]])) | write("*** undefined nonterminal: ",name)end# look for file with input#procedure source(line) local file, new return line ? { if ="@" then { new := open(file := tab(0)) | { write(&errout,"*** cannot open ",file) fail } push(ifile,in) & in := new return } }end# produce string image of grammar symbol#procedure symimage(x) return case type(x) of { "string": x "nonterm": "<" || x.name || ">" "charset": "<'" || x.chars || "'>" }end# process the symbols in an alternative#procedure syms(alt) local slist static nonbrack initial nonbrack := ~'<' slist := [] alt ? while put(slist,tab(many(nonbrack)) | defnon(2(="<",tab(upto('>')),move(1)))) return slistend :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:bench Folder:rsg.std
Icon Version 8.0x. December 12, 1989.megaron.arizona.eduUNIXASCIIco-expressionsdirect executionenvironment variableserror trace backexpandable regionsexternal functionsmath functionsmemory monitoringoverflow checkingpipesstring invocationsystem functionregionsstatic 60480string 65024block 65024*** Benchmarking with output ***as the shadowy figure stares at a lake;he alights, and turns away.momentarily she kneels.while the boy casts toward a moon;the shadowy figure turns away, and pauses.as he kneels.as the boy damns a moon;the boy kneels, while waiting darkly.momentarily the shadowy figure lingers.frozen, the boy stares at the abyss;he kneels, and alights.as the shadowy figure alights.momentarily the shadowy figure captures a sky;a child pauses, but pauses.as the shadowy figure hesitates.momentarily she damns the darkness;a child turns away, but returns.momentarily he alights.as she captures a star;the shadowy figure reflects, while breathing silently.while the boy hesitates.as she damns the abyss;she pauses, and returns.frozen, the shadowy figure kneels.as a child captures a darkness;she reflects, and hesitates.frozen, she hesitates.as the shadowy figure damns a star;the boy kneels, but kneels.as the shadowy figure stares.as he damns the abyss;a child alights, while waiting silently.while he returns.as a child outlines the void;the boy reflects, but kneels.frozen, a child turns away.frozen, he captures the lake;he hesitates, but alights.frozen, he turns away.as he damns a lake;he pauses, while waiting darkly.as the boy reflects.frozen, she casts toward the lake;he returns, and kneels.while the boy alights.frozen, the shadowy figure stares at the cloud;the boy kneels, while pointing expectantly.frozen, the boy kneels.momentarily he outlines the darkness;he pauses, while pointing darkly.as the shadowy figure reflects.momentarily a child captures a cloud;he hesitates, while breathing silently.while she pauses.frozen, the shadowy figure casts toward a cloud;he stares, and kneels.frozen, a child returns.momentarily the boy captures the cloud;the shadowy figure returns, and stares.momentarily he turns away.momentarily the boy casts toward a moon;the boy lingers, and reflects.as the boy returns.as the boy outlines a abyss;the boy kneels, and kneels.momentarily the boy reflects.frozen, the boy casts toward the moon;he pauses, and turns away.while the shadowy figure hesitates.while a child damns the darkness;he returns, while breathing fearfully.momentarily the shadowy figure kneels.frozen, he damns the lake;he alights, and turns away.frozen, she reflects.as the shadowy figure damns the lake;the shadowy figure turns away, while breathing with fear.as she lingers.as he captures the abyss;the boy alights, but lingers.while she reflects.momentarily he outlines a sky;the shadowy figure turns away, but lingers.while she lingers.while the shadowy figure casts toward the cloud;the boy lingers, and turns away.while the shadowy figure hesitates.as she outlines the star;he turns away, and turns away.frozen, a child turns away.frozen, the shadowy figure outlines a abyss;she alights, and hesitates.while he reflects.while the shadowy figure captures a abyss;he hesitates, and kneels.while he kneels.momentarily the shadowy figure damns a darkness;she returns, and kneels.frozen, she hesitates.momentarily the shadowy figure stares at a cloud;the shadowy figure lingers, and reflects.while she pauses.momentarily he stares at a darkness;the shadowy figure hesitates, while waiting fearfully.momentarily she kneels.while she stares at the cloud;he pauses, but turns away.while he kneels.as she stares at the star;she pauses, but kneels.momentarily she turns away.while he damns a moon;she lingers, and pauses.frozen, he lingers.as the boy casts toward a lake;the boy kneels, and turns away.frozen, the boy turns away.momentarily he damns the lake;the shadowy figure alights, but returns.momentarily he returns.frozen, a child captures the cloud;the shadowy figure kneels, and hesitates.while a child reflects.frozen, a child damns the moon;she alights, while breathing darkly.momentarily a child lingers.momentarily the boy damns a cloud;she kneels, and turns away.as the boy lingers.momentarily the shadowy figure stares at a lake;a child stares, and hesitates.while he returns.momentarily he stares at a star;a child pauses, while waiting expectantly.as he kneels.frozen, the boy captures the lake;the boy alights, but turns away.frozen, the boy lingers.while the boy stares at the darkness;she hesitates, while waiting with fear.while she pauses.while a child outlines a sky;a child hesitates, and reflects.as a child reflects.momentarily the shadowy figure damns the abyss;she hesitates, but alights.while the boy reflects.as the boy damns the star;a child alights, while breathing fearfully.while the boy pauses.while the boy captures the lake;a child turns away, but lingers.frozen, she hesitates.momentarily the shadowy figure damns the cloud;the boy kneels, while pointing silently.while she stares.frozen, the boy captures a sky;the boy pauses, and turns away.frozen, the boy stares.frozen, she casts toward a moon;he returns, but hesitates.while a child stares.while he outlines the moon;he turns away, and pauses.frozen, a child hesitates.momentarily the shadowy figure captures a darkness;the boy alights, and returns.as she kneels.as the shadowy figure casts toward a abyss;a child pauses, and turns away.as the shadowy figure pauses.while he captures the cloud;the shadowy figure pauses, and pauses.while he kneels.as the shadowy figure damns the star;the boy lingers, but hesitates.frozen, the shadowy figure pauses.while a child casts toward the star;a child reflects, and returns.momentarily the boy pauses.frozen, she casts toward the void;the boy kneels, and reflects.while she turns away.momentarily the shadowy figure damns a cloud;she lingers, while pointing expectantly.while a child returns.frozen, she outlines a abyss;he hesitates, but kneels.as she reflects.momentarily she damns a void;the shadowy figure kneels, while waiting slowly.as he lingers.momentarily the boy casts toward the lake;a child reflects, and kneels.while a child hesitates.momentarily he damns a sky;she lingers, while breathing with fear.as she kneels.as she casts toward a cloud;she hesitates, and kneels.frozen, the shadowy figure lingers.as a child captures the star;the boy reflects, while pointing darkly.while a child returns.while a child stares at the sky;a child kneels, while waiting slowly.momentarily he returns.momentarily a child damns the sky;the shadowy figure hesitates, while pointing silently.momentarily the boy pauses.momentarily she casts toward the darkness;she stares, while waiting darkly.momentarily the boy turns away.frozen, the shadowy figure casts toward the abyss;a child kneels, and alights.momentarily the boy stares.while he captures the lake;a child kneels, and alights.frozen, a child turns away.as the shadowy figure damns the abyss;the shadowy figure pauses, while breathing expectantly.frozen, the shadowy figure hesitates.momentarily the boy stares at the abyss;the boy returns, and hesitates.while a child lingers.while a child casts toward a darkness;the boy hesitates, and kneels.as the boy pauses.while he damns a star;the boy returns, and returns.as she hesitates.momentarily the boy outlines a cloud;the boy kneels, and alights.as the boy kneels.as the boy casts toward a abyss;the boy pauses, and turns away.frozen, she hesitates.while the boy damns a sky;she returns, and kneels.frozen, a child turns away.frozen, the boy casts toward the moon;the shadowy figure hesitates, while breathing slowly.momentarily he turns away.frozen, the shadowy figure stares at the lake;the shadowy figure lingers, while pointing with fear.while he lingers.momentarild casts toward the moon;the shadowy figure pauses, but turns away.as the shadowy figure returns.as she captures the darkness;she hesitates, and turns away.momentarily she hesitates.while the shadowy figure outlines a abyss;he returns, while pointing slowly.as he kneels.while a child outlines the lake;a child reflects, and reflects.momentarily the boy lingers.as a child stares at a void;the shadowy figure hesitates, and alights.while a child lingers.momentarily a child captures a star;he turns away, and hesitates.as he lingers.while the boy outlines a abyss;the boy pauses, and alights.frozen, she stares.as a child outlines a void;the shadowy figure lingers, but reflects.momentarily the boy lingers.frozen, the boy casts toward a sky;the boy kneels, but stares.frozen, the boy kneels.momentarily he casts toward the lake;a child turns away, while pointing silently.momentarily he kneels.while he damns a moon;a child hesitates, while waiting darkly.as the shadowy figure returns.momentarily the shadowy figure casts toward a void;a child returns, and reflects.frozen, a child pauses.frozen, the shadowy figure damns a void;a child reflects, and turns away.while a child lingers.as the boy outlines a star;the boy turns away, and pauses.frozen, a child reflects.momentarily a child damns the star;she turns away, while pointing slowly.momentarily a child hesitates.frozen, the boy stares at a void;the boy pauses, but reflects.frozen, the shadowy figure hesitates.as he casts toward a moon;the shadowy figure stares, but kneels.momentarily a child stares.as the boy captures a cloud;he turns away, but pauses.while the boy returns.frozen, the shadowy figure outlines the darkness;the shadowy figure stares, but reflects.as the boy lingers.frozen, she casts toward a cloud;a child turns away, and returns.as a child reflects.frozen, the shadowy figure stares at a abyss;he alights, but returns.frozen, he kneels.frozen, the shadowy figure casts toward a lake;he hesitates, while waiting slowly.while the shadowy figure pauses.frozen, a child outlines a sky;the shadowy figure pauses, and reflects.while the shadowy figure kneels.as he stares at the darkness;she kneels, and turns away.frozen, the boy returns.while she stares at the lake;the shadowy figure lingers, but stares.while she pauses.while the boy captures the void;he lingers, but reflects.frozen, a child kneels.while she casts toward a darkness;the shadowy figure kneels, and turns away.momentarily the boy turns away.while he outlines a moon;she stares, but turns away.frozen, a child stares.while he damns a moon;she alights, but hesitates.while she stares.as a child stares at a void;he pauses, but kneels.while the shadowy figure pauses.momentarily a child captures the lake;he kneels, but kneels.as a child kneels.while the shadowy figure captures the cloud;a child turns away, and stares.frozen, he hesitates.momentarily he captures a sky;the boy hesitates, but pauses.while she stares.frozen, a child damns the moon;the shadowy figure reflects, and turns away.while the boy pauses.frozen, the boy captures a lake;the boy pauses, and reflects.as he stares.as the boy stares at the moon;a child hesitates, and stares.as he lingers.while he outlines the cloud;a child hesitates, while pointing darkly.momentarily the boy turns away.while the boy casts toward a cloud;a child hesitates, and pauses.momentarily the boy pauses.momentarily the shadowy figure captures the darkness;the shadowy figure reflects, and hesitates.while he returns.frozen, he captures a moon;a child lingers, and hesitates.while she reflects.while the boy captures a lake;the boy turns away, and reflects.frozen, the shadowy figure turns away.while a child stares at a cloud;the shadowy figure stares, while breathing fearfully.frozen, the shadowy figure stares.as a child captures a darkness;a child kneels, but hesitates.momentarily a child stares.while he casts toward the lake;she stares, and hesitates.momentarily the boy alights.momentarily she damns the cloud;the shadowy figure stares, but returns.momentarily he pauses.frozen, she captures a void;he lingers, and lingers.frozen, she hesitates.momentarily a child stares at a star;a child lingers, but returns.momentarily a child kneels.as a child stares at a cloud;the shadowy figure alights, while pointing expectantly.as he alights.as a child captures the darkness;a child lingers, and lingers.while she kneels.frozen, a child damns a moon;a child turns away, and kneels.as a child returns.while the boy captures a star;a child returns, but alights.momentarily a child returns.momentarily he captures a lake;a child lingers, and stares.while she returns.while the shadowy figure casts toward the sky;she pauses, but returns.momentarily he kneels.as she captures the moon;the shadowy figure lingers, and returns.while the boy lingers.while she casts toward a darkness;he alights, and lingers.as he lingers.as a child casts toward a sky;a child kneels, while waiting silently.while he lingers.as the boy outlines the lake;a child reflects, while pointing expectantly.frozen, she stares.frozen, he damns the void;the shadowy figure pauses, while breathing slowly.as he reflects.while a child casts toward the moon;a child alights, but lingers.as the boy hesitates.frozen, a child damns the star;a child hesitates, but pauses.momentarily the boy hesitates.momentarily the boy outlines a sky;the shadowy figure turns away, while pointing fearfully.momentarily she hesitates.frozen, the boy casts toward the sky;she hesitates, while waiting silently.while he lingers.momentarily a child outlines the darkness;she turns away, while pointing fearfully.as the boy kneels.momentarily the shadowy figure casts toward a void;the boy alights, and returns.as he stares.momentarily the boy damns the darkness;he returns, while waiting expectantly.momentarily the shadowy figure kneels.frozen, the boy captures the sky;a child stares, while breathing slowly.momentarily a child reflects.frozen, a child captures a moon;she hesitates, while pointing silently.momentarily he pauses.as she captures a lake;he kneels, while breathing darkly.frozen, she alights.while the shadowy figure damns a cloud;he turns away, while breathing slowly.momentarily the boy pauses.while he casts toward a cloud;he pauses, and returns.while he lingers.while he stares at the moon;the boy kneels, while pointing expectantly.as a child lingers.while a child captures the abyss;the shadowy figure turns away, but turns away.frozen, the boy lingers.momentarily a child outlines a star;a child kneels, and alights.momentarily the boy hesitates.frozen, a child stares at a sky;a child hesitates, and turns away.as the boy lingers.momentarily the boy casts toward the sky;a child turns away, while pointing darkly.momentarily the boy turns away.momentarily a child stares at a lake;she hesitates, and pauses.as the shadowy figure turns away.while a child damns the moon;a child lingers, but turns away.as a child hesitates.as the boy casts toward the sky;the boy reflects, while waiting fearfully.momentarily she hesitates.as she captures a cloud;she kneels, and pauses.while the boy reflects.while she damns the moon;a child turns away, but stares.momentarily he returns.frozen, a child st
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:bench Folder:rsg.st
+++++ Continued from previous card +++++
ares at a lake;the boy turns away, and kneels.as he stares.as she stares at the lake;he turns away, and returns.while a child returns.frozen, the boy damns a lake;he returns, and hesitates.momentarily the shadowy figure returns.frozen, a child captures the abyss;a child lingers, while waiting darkly.momentarily the boy stares.as she stares at a darkness;the shadowy figure pauses, and stares.momentarily the shadowy figure lingers.while the boy captureshe lingers, while pointing silently.while a child alights.frozen, the boy captures the void;the shadowy figure pauses, and returns.frozen, he alights.while he captures a darkness;she stares, but returns.as the shadowy figure stares.momentarily a child captures the cloud;the shadowy figure stares, while waiting fearfully.frozen, she returns.while the shadowy figure damns a moon;he kneels, but reflects.frozen, a child pauses.as the shadowy figure damns a lake;the shadowy figure turns away, while pointing silently.as he pauses.frozen, a child casts toward a sky;he reflects, while breathing silently.frozen, the boy alights.frozen, a child casts toward the sky;he kneels, while waiting fearfully.as the boy returns.momentarily he stares at the abyss;a child pauses, and hesitates.as he kneels.while the boy damns the abyss;he alights, but kneels.while a child hesitates.while he captures a moon;a child returns, but hesitates.as he turns away.momentarily a child captures a moon;the boy turns away, and kneels.as the boy hesitates.while the shadowy figure captures a sky;he hesitates, but turns away.frozen, she kneels.while a child outlines a sky;the shadowy figure returns, but hesitates.momentarily she alights.as he captures the abyss;she returns, and lingers.while the boy alights.as she outlines the sky;the shadowy figure turns away, but turns away.momentarily he returns.momentarily she captures the moon;she turns away, and returns.as a child turns away.frozen, she outlines a cloud;the shadowy figure reflects, but kneels.momentarily the shadowy figure kneels.momentarily the shadowy figure damns a void;the boy pauses, while waiting with fear.as a child kneels.momentarily the boy stares at the abyss;she reflects, and pauses.frozen, a child lingers.as the shadowy figure stares at the sky;a child hesitates, but stares.frozen, he returns.while the shadowy figure casts toward the void;he alights, while breathing fearfully.frozen, she kneels.while the boy stares at a moon;the shadowy figure turns away, while waiting with fear.as he alights.as a child captures the lake;the shadowy figure hesitates, while waiting with fear.while she kneels.frozen, a child casts toward the cloud;she hesitates, and returns.while a child returns.while the shadowy figure stares at the moon;she hesitates, but reflects.frozen, he stares.frozen, he casts toward the cloud;she stares, but turns away.momentarily a child kneels.frozen, the shadowy figure stares at a star;the shadowy figure lingers, and reflects.momentarily the shadowy figure returns.frozen, he damns a void;she alights, and alights.as he stares.as she captures a star;a child alights, but pauses.momentarily the boy pauses.while she captures a darkness;the boy returns, and kneels.as she alights.momentarily she outlines the darkness;she kneels, while breathing expectantly.while a child lingers.momentarily a child damns the moon;she kneels, while waiting expectantly.as she returns.frozen, the boy stares at the star;she hesitates, while waiting slowly.as he hesitates.while she casts toward the lake;she lingers, while breathing expectantly.frozen, he stares.frozen, the shadowy figure stares at a abyss;he lingers, and alights.momentarily a child turns away.momentarily the boy stares at a darkness;the boy pauses, and stares.frozen, she reflects.momentarily the boy casts toward the cloud;he kneels, and pauses.frozen, he turns away.momentarily a child captures the lake;she stares, and turns away.as the boy turns away.while the boy damns a void;the boy kneels, while pointing expectantly.momentarily she lingers.momentarily a child damns the sky;the boy alights, but hesitates.as he stares.while the shadowy figure outlines a cloud;he hesitates, while waiting silently.as he lingers.as he damns the abyss;the shadowy figure reflects, and stares.momentarily the shadowy figure alights.while she captures a sky;she kneels, and kneels.momentarily the boy pauses.while the shadowy figure outlines a cloud;he alights, and hesitates.momentarily the shadowy figure turns away.as the shadowy figure damns the sky;the boy stares, and alights.as the boy lingers.as she damns a abyss;he returns, and reflects.momentarily the boy pauses.while he stares at the sky;she lingers, and alights.momentarily the shadowy figure lingers.while the boy captures a void;a child pauses, while breathing darkly.while a child alights.while the shadowy figure damns the lake;she stares, while pointing darkly.momentarily she reflects.frozen, she outlines the cloud;a child stares, and turns away.momentarily a child lingers.momentarily he damns the lake;he kneels, but reflects.while she kneels.momentarily she outlines a darkness;a child kneels, and lingers.as the shadowy figure alights.frozen, the boy captures the sky;a child alights, but turns away.as the shadowy figure returns.frozen, he damns a sky;the boy stares, and returns.as she returns.while he stares at the abyss;the shadowy figure kneels, and reflects.momentarily she returns.frozen, he captures a star;the boy stares, but stares.frozen, a child turns away.momentarily the shadowy figure damns the lake;a child hesitates, and hesitates.frozen, she lingers.as he outlines a moon;the shadowy figure stares, and lingers.momentarily the shadowy figure reflects.frozen, he damns a void;the boy stares, while waiting silently.while she kneels.frozen, the boy stares at a void;the shadowy figure pauses, but turns away.as the boy lingers.momentarily a child stares at a cloud;the shadowy figure stares, while pointing fearfully.momentarily a child returns.while the boy damns the abyss;a child reflects, and reflects.as the boy hesitates.frozen, he captures the darkness;the boy reflects, but turns away.while he pauses.as the shadowy figure damns a abyss;the shadowy figure lingers, and stares.frozen, a child lingers.as he casts toward the cloud;he reflects, while breathing expectantly.frozen, a child alights.while the shadowy figure stares at a cloud;he lingers, while waiting with fear.while the boy reflects.frozen, the boy outlines a moon;the boy returns, and reflects.frozen, a child stares.as a child stares at a moon;she returns, while breathing expectantly.frozen, he reflects.as he stares at a lake;a child pauses, and lingers.as the boy alights.momentarily a child damns the abyss;the shadowy figure returns, and pauses.momentarily a child turns away.momentarily the shadowy figure captures a cloud;a child pauses, and reflects.momentarily the boy reflects.as a child captures the abyss;the shadowy figure lingers, but turns away.as the boy returns.momentarily a child damns a abyss;the shadowy figure kneels, while pointing slowly.momentarily a child alights.frozen, the shadowy figure damns the abyss;he pauses, but stares.frozen, he alights.while she outlines a star;a child kneels, and reflects.while a child pauses.frozen, she outlines the sky;he alights, and alights.momentarily the boy pauses.as the boy stares at a lake;she kneels, and alights.momentarily the boy lingers.as a child casts toward the abyss;the boy hesitates, and stares.as he alights.while she outlines the void;the boy reflects, but hesitates.as a child pauses.frozen, the boy stares at the sky;a child returns, while waiting fearfully.while he turns away.as a child outlines the moon;he returns, while breathing with fear.momentarily a child returns.frozen, the boy outlines the star;a child turns away, and hesitates.frozen, the shadowy figure stares.frozen, the shadowy figure damns the star;the shadowy figure returns, while breathing slowly.while the boy lingers.as a child damns the moon;he returns, but stares.as she lingers.frozen, the shadowy figure captures the cloud;a child alights, but turns away.frozen, he alights.frozen, he stares at the lake;he stares, while breathing darkly.momentarily she alights.frozen, the shadowy figure captures a cloud;she turns away, while waiting fearfully.frozen, the boy alights.frozen, the shadowy figure casts toward a moon;she lingers, but reflects.as she turns away.momentarily the boy captures a cloud;the boy kneels, and alights.while she stares.momentarily the boy captures the void;the boy kneels, and turns away.while the boy pauses.frozen, she damns a moon;the shadowy figure kneels, but hesitates.while he pauses.while the shadowy figure captures a lake;she kneels, and kneels.while the shadowy figure hesitates.as she casts toward a sky;the shadowy figure lingers, and kneels.as a child reflects.as she damns a star;the boy lingers, but reflects.while the boy hesitates.while a child damns a sky;she pauses, and lingers.momentarily a child kneels.frozen, she casts toward the darkness;she returns, and turns away.frozen, he turns away.while she casts toward the darkness;he stares, and returns.as she reflects.frozen, a child casts toward a cloud;a child lingers, but turns away.frozen, the shadowy figure reflects.momentarily the boy outlines a abyss;the shadowy figure hesitates, but pauses.while a child reflects.frozen, the boy captures the sky;he returns, and stares.while she returns.as he casts toward the void;she kneels, while breathing silently.while she hesitates.momentarily he captures the sky;he turns away, and lingers.momentarily she reflects.frozen, the shadowy figure damns a void;he stares, while waiting silently.as he alights.frozen, a child captures a cloud;the boy returns, and pauses.as she lingers.frozen, the shadowy figure stares at the star;he stares, but stares.momentarily she turns away.frozen, he damns a abyss;she lingers, but returns.as a child lingers.momentarily he stares at a darkness;the boy reflects, and alights.frozen, the shadowy figure hesitates.as she stares at a abyss;the shadowy figure lingers, but kneels.frozen, the shadowy figure lingers.while the shadowy figure outlines a sky;she hesitates, and kneels.frozen, the boy kneels.as he outlines the cloud;a child kneels, while waiting silently.while the shadowy figure returns.while a child outlines the star;she reflects, but stares.frozen, a child turns away.momentarily a child captures the star;the shadowy figure lingers, but kneels.frozen, the boy turns away.as a child captures a abyss;the shadowy figure hesitates, while breathing darkly.while he turns away.while the shadowy figure captures the moon;she kneels, while breathing with fear.frozen, a child kneels.frozen, the boy stares at the cloud;she turns away, and returns.momentarily she alights.as he captures the sky;a child alights, while breathing silently.while he lingers.frozen, he stares at a abyss;the shadowy figure lingers, and turns away.while she hesitates.frozen, the shadowy figure stares at the lake;the boy pauses, and lingers.while she stares.frozen, she captures a abyss;he reflects, and hesitates.momentarily the boy pauses.as she outlines a abyss;the boy alights, and reflects.frozen, she returns.while he stares at a abyss;the shadowy figure kneels, and lingers.momentarily she turns away.as she outlines the abyss;the shadowy figure hesitates, while breathing fearfully.as the boy reflects.as he outlines a lake;he returns, while breathing slowly.momentarily she alights.while he stares at the lake;he turns away, but returns.frozen, the shadowy figure turns away.frozen, the boy casts toward the void;he hesitates, and lingers.as the boy alights.frozen, the boy captures a void;the boy pauses, while waiting with fear.frozen, he stares.while he outlines a abyss;the boy kneels, while waiting fearfully.while a child kneels.as the shadowy figure captures a star;he pauses, and reflects.momentarily she turns away.momentarily he outlines a moon;he kneels, while pointing with fear.as he hesitates.momentarily the shadowy figure outlines the lake;the boy stares, and reflects.frozen, he stares.momentarily she captures the abyss;a child lingers, and turns away.momentarily the boy stares.while the shadowy figure stares at a darkness;she reflects, but stares.as he turns away.while the shadowy figure captures a moon;the shadowy figure alights, while breathing darkly.frozen, he lingers.frozen, the boy casts toward a sky;he lingers, while waiting with fear.momentarily the shadowy figure returns.as the shadowy figure stares at the cloud;he lingers, while pointing darkly.frozen, the shadowy figure returns.while the boy outlines a cloud;he reflects, and reflects.while he lingers.as the shadowy figure casts toward the darkness;a child kneels, and stares.momentarily she stares.as he captures the cloud;the shadowy figure stares, but reflects.while a child alights.momentarily a child damns the darkness;a child kneels, and turns away.while a child turns away.as the shadowy figure captures the cloud;he lingers, and hesitates.while the boy returns.as he outlines a star;he hesitates, while pointing slowly.frozen, a child pauses.frozen, she damns a lake;a child turns away, but returns.frozen, a child hesitates.momentarily she stares at the star;she returns, and stares.momentarily the shadowy figure pauses.as the shadowy figure stares at a darkness;the boy alights, but hesitates.while she kneels.while the shadowy figure casts toward a moon;the boy pauses, and stares.as a child stares.frozen, he casts toward the abyss;she alights, and lingers.while she kneels.while a child damns a moon;the boy stares, but lingers.as the boy returns.as a child stares at a abyss;she hesitates, while waiting with fear.momentarily a child reflects.frozen, the shadowy figure captures a abyss;he kneels, and pauses.as she turns away.as the shadowy figure damns a abyss;a child hesitates, and lingers.as he pauses.while he damns the cloud;the boy alights, and kneels.frozen, the boy hesitates.momentarily she damns the moon;she returns, but hesitates.as the shadowy figure hesitates.as the shadowy figure casts toward the star;the shadowy figure returns, and reflects.momentarily the shadowy figure pauses.as the shadowy figure outlines the sky;a child kneels, and pauses.while the shadowy figure alights.while the boy casts toward a star;he turns away, but turns away.momentarily a child alights.frozen, a child stares at the sky;a child stares, but pauses.while the shadowy figure stares.while he stares at the darkness;a child kneels, and stares.momentarily a child kneels.frozen, she casts toward a lake;the boy turns away, and lingers.frozen, the shadowy figure kneels.as the shadowy figure captures the void;he alights, and stares.frozen, the boy lingers.frozen, the shadowy figure damns the void;the boy pauses, but alights.frozen, a child returns.momentarily he casts toward a darkness;the shadowy figure pauses, but pauses.frozen, he alights.while she outline
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:bench Folder:rsg.st
+++++ Continued from previous card +++++
s the star;he returns, and alights.while a child reflects.frozen, the boy casts toward a abyss;the shadowy figure pauses, but kneels.frozen, a child stares.as the shadowy figure damns the void;a child reflects, while pointing expectantly.frozen, the shadowy figure hesitates.while he stares at a moon;the shadowy figure alights, while breathing slowly.momentarily the boy returns.as a child casts toward the cloud;he stares, and turns away.momentarily she lingers.as the boy outlines a darkness;the shadowy figure returns, but returns.momentarily he kneels.as a child damns a darkness;a child pauses, while breathing expectantly.frozen, he reflects.frozen, he casts toward the void;a child kneels, and pauses.as she hesitates.as he damns the darkness;the shadowy figure pauses, while pointing silently.momentarily the shadowy figure lingers.momentarily he outlines a sky;the shadowy figure pauses, but lingers.frozen, she pauses.frozen, the boy outlines a sky;the boy hesitates, while waiting expectantly.momentarily he lingers.momentarily a child captures the darkness;the boy lingers, and hesitates.frozen, he alights.momentarily a child outlines the moon;she alights, while waiting slowly.frozen, the boy stares.as he stares at the star;she turns away, and stares.while the boy alights.momentarily he casts toward the lake;a child reflects, but stares.frozen, a child turns away.momentarily the shadowy figure outlines a darkness;he stares, and turns away.momentarily he reflects.as the boy stares at the void;the shadowy figure alights, and returns.momentarily the shadowy figure reflects.while the shadowy figure stares at a cloud;the boy turns away, and kneels.while he kneels.momentarily a child captures a void;she kneels, and kneels.while he kneels.while the shadowy figure casts toward the lake;she lingers, and stares.as he pauses.momentarily she damns the star;he hesitates, and reflects.as he turns away.while he stares at the void;she reflects, while breathing with fear.as the shadowy figure reflects.momentarily a child outlines a abyss;he alights, while breathing fearfully.as the boy alights.while he casts toward a moon;a child reflects, but hesitates.while he pauses.momentarily the shadowy figure captures the moon;the boy alights, but alights.as a child pauses.frozen, a child stares at the abyss;the shadowy figure kneels, and kneels.momentarily a child stares.frozen, she damns the darkness;he lingers, and kneels.while the boy alights.frozen, he damns a void;a child pauses, and pauses.momentarily a child hesitates.as the shadowy figure stares at a star;she lingers, and turns away.while he kneels.momentarily the boy stares at a darkness;she lingers, and hesitates.momentarily the boy alights.while he casts toward the moon;a child pauses, while pointing with fear.frozen, the shadowy figure lingers.frozen, she casts toward a void;the boy kneels, but pauses.while a child returns.as the shadowy figure captures the lake;he hesitates, and kneels.while the boy alights.momentarily a child casts toward the moon;the boy reflects, but kneels.while the shadowy figure lingers.frozen, the boy outlines the cloud;the shadowy figure returns, and pauses.frozen, the boy returns.frozen, the shadowy figure captures the cloud;the shadowy figure returns, and alights.while he hesitates.while the shadowy figure captures a lake;a child hesitates, and lingers.frozen, she lingers.as he casts toward the cloud;the boy lingers, and alights.momentarily a child alights.momentarily the boy stares at the moon;the shadowy figure returns, but returns.momentarily the shadowy figure returns.momentarily he casts toward the darkness;the shadowy figure turns away, and returns.momentarily the shadowy figure returns.frozen, she outlines a abyss;the boy lingers, and alights.frozen, he lingers.as a child damns a moon;she returns, and hesitates.frozen, he pauses.while the shadowy figure damns a star;she kneels, but returns.momentarily a child turns away.while he stares at the void;a child alights, and pauses.momentarily a child lingers.as a child captures the void;a child stares, and hesitates.as the shadowy figure lingers.frozen, a child captures a moon;a child hesitates, but returns.while she kneels.frozen, the boy stares at the star;she lingers, and hesitates.while he reflects.momentarily she stares at the abyss;he lingers, and pauses.as the shadowy figure turns away.while a child captures a moon;she pauses, but pauses.as the boy stares.momentarily he outlines the void;the boy kneels, but alights.as she returns.frozen, the boy outlines a cloud;she kneels, while waiting with fear.as the shadowy figure hesitates.as she casts toward the sky;the boy alights, and kneels.as she lingers.frozen, the shadowy figure captures the darkness;the boy lingers, while pointing darkly.as the boy alights.while a child captures the star;she kneels, but kneels.frozen, the boy stares.while a child outlines the cloud;she hesitates, and alights.as the boy alights.while the boy outlines a moon;a child returns, while pointing fearfully.while the shadowy figure returns.as she casts toward a star;a child turns away, and hesitates.while the shadowy figure hesitates.while the shadowy figure captures the void;she hesitates, and turns away.momentarily he kneels.as she captures the darkness;she turns away, but pauses.frozen, she returns.while she stares at a void;a child stares, and kneels.as she reflects.frozen, the boy outlines a void;the shadowy figure returns, but returns.frozen, the shadowy figure kneels.as a child stares at the moon;the boy alights, but turns away.momentarily he turns away.frozen, she captures the lake;the boy reflects, and turns away.frozen, the shadowy figure returns.frozen, she casts toward a sky;the shadowy figure stares, and kneels.while the boy turns away.while the boy captures a cloud;the boy returns, and turns away.as the boy alights.while the shadowy figure damns a lake;the shadowy figure lingers, and kneels.while a child stares.momentarily he outlines the lake;she alights, and stares.frozen, a child turns away.as a child damns the moon;the shadowy figure turns away, and pauses.frozen, a child hesitates.as the shadowy figure damns the star;she turns away, and kneels.frozen, a child stares.frozen, a child captures a darkness;the boy stares, but returns.while he reflects.as he captures the sky;the shadowy figure turns away, but stares.while a child alights.while the boy outlines the abyss;the shadowy figure lingers, while pointing darkly.as the boy lingers.while a child captures the star;the boy alights, but returns.while the shadowy figure returns.while the shadowy figure captures a sky;he turns away, while pointing silently.as she returns.as the shadowy figure captures a lake;a child pauses, and pauses.while she reflects.while the boy stares at the void;she turns away, and hesitates.while the shadowy figure turns away.as a child captures a cloud;she hesitates, and stares.frozen, she stares.while the shadowy figure damns the darkness;she kneels, and alights.as the shadowy figure lingers.while she captures the sky;a child reflects, but turns away.frozen, he reflects.momentarily he casts toward a star;the boy lingers, while pointing expectantly.frozen, the boy turns away.momentarily the boy outlines a void;a child kneels, and stares.while she turns away.while the shadowy figure captures the abyss;the shadowy figure reflects, and turns away.momentarily she alights.as the shadowy figure casts toward a moon;the shadowy figure turns away, and kneels.while she reflects.as he captures the void;the shadowy figure alights, and stares.frozen, she pauses.as the boy outlines a cloud;the shadowy figure returns, and pauses.frozen, the boy turns away.frozen, the shadowy figure stares at the moon;a child kneels, and hesitates.momentarily the boy lingers.momentarily the shadowy figure captures a abyss;the shadowy figure turns away, but reflects.while the boy reflects.momentarily he casts toward a moon;a child alights, but turns away.while the shadowy figure pauses.frozen, she captures a moon;a child stares, and returns.as she reflects.while the shadowy figure captures a darkness;a child pauses, while waiting expectantly.frozen, the boy kneels.while the shadowy figure captures a cloud;the shadowy figure pauses, and hesitates.frozen, she returns.while he stares at a lake;a child pauses, while breathing silently.frozen, she lingers.while the shadowy figure casts toward the sky;she pauses, but returns.as the shadowy figure alights.frozen, the boy casts toward a cloud;a child kneels, and hesitates.as the shadowy figure turns away.momentarily a child damns a darkness;a child lingers, and reflects.while a child returns.as a child damns a cloud;the shadowy figure kneels, while waiting silently.while the shadowy figure hesitates.momentarily she captures a moon;the boy reflects, and hesitates.momentarily he hesitates.frozen, she stahe void;he pauses, but turns away.as the boy stares.as the boy stares at a abyss;a child turns away, and reflects.while he reflects.momentarily he stares at a lake;a child reflects, and lingers.as the boy lingers.as the shadowy figure casts toward the void;she turns away, and returns.as the shadowy figure reflects.frozen, the boy damns a cloud;he pauses, and stares.as the shadowy figure lingers.while a child damns the darkness;a child lingers, while pointing silently.as she turns away.momentarily the boy stares at the lake;the boy alights, and returns.while he stares.momentarily a child damns the cloud;a child hesitates, but hesitates.momentarily the shadowy figure alights.as she damns the void;the shadowy figure returns, and hesitates.while a child hesitates.while the boy outlines a lake;a child pauses, but reflects.while the shadowy figure lingers.momentarily the boy damns the sky;the shadowy figure alights, but alights.while the shadowy figure alights.as she stares at the lake;the boy turns away, and reflects.while a child stares.while the boy captures a cloud;he returns, while waiting expectantly.frozen, he kneels.momentarily she outlines the moon;the boy lingers, but pauses.while he lingers.while the shadowy figure captures a darkness;he turns away, and turns away.as a child pauses.as the boy damns a cloud;the boy returns, while breathing slowly.while the shadowy figure reflects.while he captures the lake;a child stares, but returns.while the boy stares.frozen, she stares at a sky;the boy alights, and alights.frozen, he hesitates.as he damns the darkness;he lingers, and hesitates.frozen, he reflects.frozen, the shadowy figure stares at a star;he returns, and stares.momentarily a child alights.momentarily a child damns a abyss;he reflects, but hesitates.frozen, he pauses.as he stares at a moon;he lingers, and kneels.momentarily the boy pauses.momentarily the shadowy figure outlines a void;a child returns, and turns away.momentarily she turns away.as the boy damns a abyss;she lingers, but alights.momentarily he pauses.as she casts toward a star;the shadowy figure reflects, and turns away.while he stares.frozen, a child captures a sky;she hesitates, but stares.momentarily a child kneels.frozen, the shadowy figure damns the sky;he kneels, and kneels.while a child turns away.momentarily the shadowy figure outlines the sky;the boy kneels, and lingers.as the shadowy figure turns away.momentarily he damns the star;she lingers, and turns away.frozen, he turns away.as the shadowy figure casts toward a void;the boy reflects, and returns.while she pauses.as the shadowy figure casts toward the void;the shadowy figure lingers, while breathing fearfully.as the boy alights.as a child casts toward a void;she alights, and stares.while the boy lingers.while the shadowy figure casts toward a abyss;the boy lingers, and stares.as a child stares.momentarily the boy stares at a abyss;a child reflects, and lingers.as she returns.while the shadowy figure damns a star;he turns away, and returns.while a child hesitates.as a child captures the darkness;a child alights, while waiting slowly.as he hesitates.as he damns the star;the boy pauses, and turns away.frozen, a child turns away.as the shadowy figure outlines a void;she turns away, while pointing silently.as she returns.momentarily he stares at the sky;he reflects, and returns.while she returns.as he damns a moon;he hesitates, and kneels.as she turns away.as she outlines a cloud;he returns, but reflects.frozen, the boy kneels.momentarily she casts toward the cloud;the shadowy figure lingers, and alights.as the shadowy figure returns.momentarily she captures the void;the boy returns, while breathing slowly.momentarily the shadowy figure alights.momentarily she casts toward a sky;a child reflects, while breathing slowly.momentarily she stares.while he captures a abyss;a child turns away, and reflects.momentarily a child pauses.as the boy stares at a sky;the boy stares, and hesitates.as a child alights.frozen, the boy captures a cloud;a child returns, and stares.while he alights.while she stares at the darkness;the boy kneels, and kneels.frozen, he kneels.momentarily the shadowy figure stares at the cloud;a child returns, and reflects.momentarily he pauses.momentarily a child captures the void;the shadowy figure alights, but kneels.frozen, the shadowy figure turns away.while a child casts toward a cloud;she turns away, but returns.while he hesitates.frozen, a child stares at the star;a child stares, and hesitates.momentarily she hesitates.momentarily the shadowy figure outlines a cloud;she lingers, and turns away.as the shadowy figure alights.while she stares at the star;the shadowy figure turns away, and hesitates.frozen, the boy pauses.frozen, a child damns the darkness;she lingers, but reflects.while she hesitates.frozen, the shadowy figure stares at a cloud;she alights, while waiting expectantly.momentarily a child stares.while a child captures the void;a child alights, and lingers.momentarily the shadowy figure pauses.momentarily the shadowy figure casts toward the void;a child reflects, and turns away.momentarily she pauses.momentarily a child outlines the star;the boy hesitates, but returns.frozen, he turns away.frozen, the boy stares at a abyss;she reflects, but stares.while he turns away.while a child captures the abyss;the boy returns, but alights.while the boy returns.while he casts toward the sky;the boy turns away, and alights.momentarily the shadowy figure turns away.while he damns a darkness;he returns, while pointing fearfully.while she hesitates.as she outlines the cloud;he kneels, while breathing silently.while she pauses.while the boy captures a void;a child hesitates, but lingers.momentarily the boy stares.frozen, the boy damns a abyss;a child hesitates, and pauses.while he reflects.while the shadowy figure stares at a darkness;he stares, and reflects.momentarily the shadowy figure reflects.as she outlines the moon;the shadowy figure lingers, but returns.while the shadowy figure kneels.momentarily the boy outlines the star;a child alights, but turns away.momentarily she stares.f
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:bench Folder:rsg.st
+++++ Continued from previous card +++++
rozen, a child casts toward a darkness;a child pauses, and hesitates.as he stares.frozen, the boy captures a star;the shadowy figure turns away, but reflects.frozen, she hesitates.while the shadowy figure outlines a darkness;a child alights, and alights.as a child kneels.momentarily a child stares at the sky;the boy turns away, and pauses.frozen, the shadowy figure lingers.as she damns the void;the boy lingers, while waiting with fear.frozen, she stares.momentarily he outlines the void;a child pauses, and turns away.frozen, a child kneels.as she damns a cloud;he lingers, and reflects.frozen, she returns.frozen, the shadowy figure casts toward the abyss;a child lingers, and kneels.as the shadowy figure pauses.as a child casts toward the moon;a child kneels, while pointing silently.while she hesitates.while the shadowy figure stares at a moon;he stares, while breathing slowly.frozen, he alights.frozen, she casts toward a sky;he hesitates, and alights.while the shadowy figure lingers.momentarily she captures a lake;the shadowy figure stares, but lingers.as the boy lingers.as a child outlines the star;the shadowy figure returns, but lingers.while the shadowy figure reflects.while a child outlines the moon;the shadowy figure stares, while breathing fearfully.while she pauses.momentarily the boy damns the darkness;he reflects, and pauses.while the boy alights.while a child stares at the moon;the shadowy figure pauses, and turns away.as she pauses.as she casts toward a star;she lingers, and kneels.as a child pauses.while he casts toward the void;he reflects, but hesitates.while the boy lingers.momentarily he stares at the abyss;the shadowy figure stares, while waiting fearfully.while the boy lingers.momentarily she damns the darkness;the shadowy figure pauses, but stares.while a child pauses.while the boy outlines a star;the boy turns away, while breathing expectantly.momentarily he hesitates.while the shadowy figure captures the lake;the boy reflects, and lingers.while the shadowy figure kneels.as the boy stares at the sky;he lingers, but alights.frozen, the shadowy figure returns.frozen, she damns the cloud;she hesitates, but stares.as a child returns.momentarily she outlines a darkness;a child returns, but reflects.frozen, the shadowy figure alights.momentarily a child damns the moon;the shadowy figure alights, and lingers.frozen, the shadowy figure kneels.momentarily a child outlines the star;the boy pauses, and hesitates.while a child reflects.while a child outlines a void;the shadowy figure kneels, while waiting silently.as she pauses.while she stares at a void;he reflects, but turns away.while the boy hesitates.while the boy captures the lake;the boy stares, but kneels.momentarily she stares.as she stares at the lake;a child lingers, but stares.while the boy lingers.frozen, a child captures the star;the boy hesitates, but reflects.momentarily a child lingers.momentarily he casts toward a cloud;the shadowy figure alights, and alights.as a child reflects.while she casts toward a moon;she stares, but stares.while she hesitates.momentarily a child stares at the star;he reflects, but turns away.as he alights.as she stares at a cloud;he lingers, but lingers.while a child lingers.while the boy stares at a star;a child turns away, and stares.as the shadowy figure turns away.momentarily the shadowy figure captures a moon;a child returns, while pointing silently.momentarily she lingers.frozen, the shadowy figure stares at the sky;she kneels, and reflects.momentarily he kneels.as the boy stares at a void;she kneels, but stares.while she lingers.frozen, the shadowy figure casts toward a void;a child reflects, while pointing slowly.while the boy lingers.as the shadowy figure outlines the void;the boy alights, and reflects.frozen, a child lingers.while he casts toward the void;a child lingers, and reflects.frozen, the boy turns away.momentarily he captures the lake;the boy stares, while pointing fearfully.while a child hesitates.frozen, the boy captures a moon;a child reflects, but alights.momentarily she hesitates.momentarily he casts toward a lake;a child kneels, and lingers.momentarily she pauses.while the boy outlines the lake;she stares, while breathing darkly.while she returns.frozen, the boy outlines a star;the boy pauses, and reflects.as the shadowy figure stares.as a child casts toward a darkness;a child lingers, while pointing silently.momentarily a child stares.frozen, the shadowy figure outlines the moon;she alights, and pauses.as the shadowy figure kneels.frozen, a child stares at the darkness;the shadowy figure alights, but alights.frozen, the shadowy figure hesitates.while the boy captures a lake;a child turns away, and turns away.while a child kneels.while he captures a lake;the boy reflects, while waiting fearfully.while a child pauses.as the boy outlines the lake;the boy returns, and lingers.as she turns away.momentarily the boy stares at the abyss;a child pauses, while pointing expectantly.as the boy returns.frozen, he casts toward the cloud;the boy reflects, while waiting with fear.while a child turns away.as a child stares at a void;the boy lingers, while waiting silently.as the boy pauses.while the shadowy figure damns a moon;the boy lingers, and alights.frozen, a child pauses.while the shadowy figure damns a sky;he kneels, while waiting fearfully.as a child pauses.while the shadowy figure stares at a void;he pauses, and lingers.momentarily the shadowy figure returns.as he captures the cloud;the boy turns away, and hesitates.while she hesitates.as a child damns the star;the boy reflects, and lingers.momentarily the shadowy figure stares.frozen, the boy damns the lake;the boy lingers, and hesitates.momentarily he kneels.momentarily the boy damns the lake;he lingers, and alights.as the shadowy figure lingers.frozen, the boy captures a darkness;she pauses, but stares.while a child returns.frozen, the shadowy figure outlines a sky;a child stares, and turns away.frozen, he returns.as he outlines the moon;he kneels, while breathing silently.as a child kneels.as a child damns a star;a child stares, and turns away.momentarily the boy reflects.frozen, a child outlines the lake;a child stares, but hesitates.as she pauses.while the boy damns the cloud;the shadowy figure turns away, while pointing with fear.frozen, the shadowy figure stares.momentarily she damns a star;the boy turns away, but reflects.as a child alights.while the boy damns the abyss;the shadowy figure hesitates, but stares.while the boy alights.while she outlines the abyss;he reflects, and returns.while a child reflects.momentarily she captures the darkness;she hesitates, and alights.frozen, a child turns away.frozen, he outlines a cloud;she returns, while waiting darkly.while a child pauses.while the shadowy figure damns the sky;a child turns away, and lingers.momentarily he reflects.frozen, the boy outlines a moon;a child returns, and reflects.momentarily the shadowy figure hesitates.while he stares at a star;the shadowy figure returns, and alights.as the shadowy figure reflects.frozen, he casts toward a cloud;he hesitates, but alights.momentarily he stares.as she captures a lake;he returns, and pauses.frozen, the boy hesitates.frozen, the shadowy figure outlines a lake;the shadowy figure kneels, while waiting fearfully.frozen, a child kneels.while the shadowy figure damns the lake;a child kneels, but hesitates.as the boy turns away.momentarily she damns the darkness;the shadowy figure turns away, and pauses.while the boy reflects.frozen, he casts toward the cloud;he lingers, and pauses.momentarily a child pauses.while the boy casts toward the abyss;the boy kneels, while pointing slowly.while she turns away.while he damns a abyss;the boy alights, and alights.while the boy pauses.frozen, she captures a darkness;he pauses, while pointing fearfully.while the shadowy figure alights.momentarily he damns the cloud;the boy hesitates, but pauses.while the boy alights.while a child outlines the cloud;the shadowy figure stares, and hesitates.while the shadowy figure reflects.frozen, she stares at the lake;a child lingers, but alights.while she hesitates.as a child captures the star;a child alights, and lingers.while a child turns away.as the boy damns the moon;the shadowy figure pauses, and hesitates.as a child pauses.frozen, he captures a star;the shadowy figure lingers, and kneels.while a child stares.while she outlines the moon;she lingers, but kneels.as the shadowy figure alights.momentarily the boy captures a sky;she pauses, while breathing slowly.momentarily she returns.momentarily she casts toward the cloud;the shadowy figure turns away, while waiting silently.momentarily the boy lingers.while he casts toward a darkness;the shadowy figure kneels, but hesitates.frozen, he kneels.while she captures the abyss;he kneels, while breathing silently.frozen, he lingers.momentarily the boy casts toward a cloud;she hesitates, and pauses.while she turns away.as a child damns the lake;the boy reflects, while breathing silently.as the boy pauses.momentarily a child casts toward the darkness;she stares, but pauses.as he returns.while a child casts toward the moon;the shadowy figure turns away, but reflects.frozen, he pauses.as a child stares at the sky;a child hesitates, but pauses.frozen, she turns away.frozen, a child casts toward the star;the boy hesitates, but pauses.as she returns.as she captures the sky;the shadowy figure turns away, and reflects.as he lingers.while he casts toward a abyss;she alights, but kneels.while the shadowy figure lingers.as a child damns the star;a child lingers, but hesitates.momentarily he hesitates.as the shadowy figure casts toward a cloud;the shadowy figure returns, while breathing slowly.as the boy turns away.while he damns the star;she lingers, but kneels.as the boy alights.frozen, the shadowy figure captures the abyss;a child lingers, and hesitates.while the shadowy figure hesitates.momentarily a child captures a sky;she hesitates, and turns away.as a child kneels.frozen, he captures a abyss;the shadowy figure reflects, and turns away.momentarily a child turns away.momentarily he damns a darkness;the boy lingers, while breathing silently.momentarily she lingers.while she captures the darkness;he reflects, but hesitates.frozen, the boy pauses.as the boy stares at the moon;a child hesitates, while breathing darkly.frozen, a child hesitates.frozen, the shadowy figure casts toward the cloud;she kneels, but alights.while she turns away.as he casts toward the sky;the boy turns away, but alights.as a child reflects.frozen, he stares at the sky;the boy returns, but hesitates.frozen, she kneels.momentarily she casts toward the sky;a child returns, but returns.as a child reflects.frozen, the boy casts toward a void;the boy stares, and reflects.momentarily a child reflects.momentarily he stares at the cloud;she hesitates, and lingers.momentarily she reflects.as the shadowy figure outlines a void;a child lingers, but returns.while she alights.frozen, the boy damns the cloud;she pauses, while waiting fearfully.while a child pauses.frozen, the shadowy figure captures the star;he pauses, and hesitates.as the boy stares.as she stares at the darkness;the shadowy figure turns away, but reflects.as the boy returns.as he captures the star;she pauses, but pauses.as the shadowy figure reflects.frozen, the boy captures the moon;the shadowy figure hesitates, but lingers.frozen, she turns away.momentarily she captures a star;the boy alights, while pointing darkly.frozen, the shadowy figure pauses.as he casts toward the cloud;the shadowy figure alights, and kneels.as a child returns.frozen, she captures a abyss;the boy pauses, but turns away.as she lingers.momentarily the shadowy figure damns a star;she alights, but lingers.momentarily he stares.frozen, he casts toward the void;the boy turns away, and reflects.as he reflects.momentarily the boy outlines a cloud;a child turns away, and hesitates.frozen, the boy reflects.while she outlines a darkness;she reflects, while pointing expectantly.while the shadowy figure stares.as the shadowy figure stares at a void;the boy stares, but turns away.while the boy kneels.frozen, she casts toward a sky;he alights, while breathing fearfully.momentarily a child returns.while the boy stares at a lake;the boy turns away, and lingers.as she pauses.while the boy casts toward a abyss;the shadowy figure turns away, while waiting with fear.while she lingers.momentarily the shadowy figure stares at a cloud;he stares, and turns away.frozen, a child turns away.while the boy damns the void;the boy pauses, and turns away.frozen, he pauses.momentarily the shadowy figure stares at the darkness;a child returns, and alights.frozen, the boy reflects.momentarily the boy stares at the void;he lingers, and lingers.frozen, the shadowy figure reflects.as he damns the sky;the shadowy figure reflects, but hesitates.frozen, the boy hesitates.as she damns the cloud;a child stares, but kneels.as she returns.as he captures the cloud;a child lingers, but hesitates.frozen, he turns away.momentarily the shadowy figure casts toward a sky;the boy pauses, but alights.as she turns away.momentarily she casts toward the abyss;the shadowy figure lingers, but returns.momentarily a child lingers.while she damns the void;the shadowy figure hesitates, while breathing fearfully.momentarily the boy turns away.frozen, she outlines the void;the shadowy figure returns, while pointing expectantly.as the boy kneels.while he stares at a moon;the shadowy figure turns away, while pointing with fear.frozen, a child returns.as the shadowy figure stares at a abyss;she reflects, while breathing darkly.momentarily a child alights.frozen, the boy damns the sky;he returns, and pauses.momentarily a child kneels.momentarily the boy captures a void;a child returns, while breathing silently.as he hesitates.while she casts toward a void;she hesitates, and lingers.momentarily she returns.frozen, a child captures the abyss;a child pauses, and turns away.while a child hesitates.momentarily the shadowy figure stares at the void;a child returns, and returns.momentarily he stares.frozen, a child casts toward a lake;she reflects, and pauses.frozen, the shadowy figure lingers.momentarily a child casts toward a void;the shadowy figure reflects, and hesitates.while the shadowy figure turns away.momentarily she damns the void;the shadowy figure kneels, while breathing fearfully.frozen, she returns.while the boy outlines a darkness;she alights, but kneels.as a child kneels.frozen, a child damns the abyss;the shadowy figure alights, but alights.while she hesitates.as a child damns the star;the shadowy figure alights, and stares.momentarily the shadowy figure lingers.momentarily he stares at the moon;the shadowy figure turns away, and alights.frozen, she returns.momentarily he captures the moon;a child lingers, and hesitates.as the shadowy figure reflects.while a child captures the cloud;the shadowy figure returns, while breathing darkly.as a child returns
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:bench Folder:rsg.st
+++++ Continued from previous card +++++
.momentarily the boy stares at a cloud;the boy returns, and pauses.while a child stares.while he casts toward the cloud;the shadowy figure hesitates, and reflects.as the shadowy figure turns away.as he outlines the void;a child hesitates, and kneels.while the shadowy figure hesitates.frozen, a child casts toward a cloud;she alights, and kneels.as a child alights.while the boy captures a star;she alights, and turns away.while the shadowy figure hesitates.as the boy casts toward the darkness;she reflects, and reflects.frozen, he reflects.as a child outlines the cloud;he stares, and returns.frozen, the shadowy figure pauses.momentarily she captures the void;she alights, and alights.frozen, a child pauses.while the boy captures a sky;she lingers, and turns away.momentarily she lingers.while she captures a sky;a child alights, and stares.frozen, he turns away.frozen, the shadowy figure outlines a cloud;a child hesitates, while pointing fearfully.frozen, she returns.while the boy outlines a darkness;he returns, and stares.momentarily she returns.momentarily he stares at a lake;she returns, while pointing with fear.while the shadowy figure turns away.momentarily a child damns a star;he turns away, but stares.while the boy reflects.momentarily he casts toward the lake;a child turns away, and alights.momentarily a child turns away.momentarily the shadowy figure outlines the lake;he hesitates, and reflects.frozen, she alights.as a child outlines the lake;the boy alights, while pointing with fear.while a child hesitates.momentarily the shadowy figure stares at a void;she stares, and alights.frozen, he pauses.while the boy captures the cloud;the boy reflects, but reflects.as the boy lingers.while she stares at a star;the boy reflects, and lingers.momentarily she reflects.momentarily the boy captures a darkness;the shadowy figure kneels, and returns.while the boy returns.while the boy stares at a abyss;a child turns away, while pointing silently.momentarily she hesitates.while he damns the cloud;a child hesitates, and turns away.as he reflects.frozen, a child casts toward the cloud;a child returns, and alights.momentarily a child turns away.momentarily he outlines the moon;he lingers, and turns away.while she turns away.while he stares at the moon;she kneels, and reflects.momentarily a child alights.while he stares at a lake;the boy returns, but returns.frozen, the shadowy figure reflects.while she outlines a star;she turns away, but alights.as a child returns.as the boy captures the darkness;he returns, while pointing silently.while the shadowy figure reflects.while the boy damns a sky;the shadowy figure lingers, and kneels.frozen, the boy alights.momentarily the shadowy figure stares at the cloud;the boy stares, while pointing with fear.momentarily she stares.frozen, she captures the cloud;she reflects, while breathing fearfully.while a child reflects.while he captures the cloud;she reflects, and hesitates.as the boy lingers.while a child outlines the abyss;a child pauses, while pointing fearfully.frozen, the shadowy figure turns away.frozen, the boy damns the cloud;the shadowy figure reflects, and alights.frozen, she turns away.as the boy stares at a lake;the boy reflects, but pauses.while she pauses.as he outlines a cloud;he hesitates, while pointing fearfully.as she pauses.while the shadowy figure outlines the cloud;he hesitates, and kneels.while she alights.while the boy outlines a lake;the boy turns away, but reflects.as the boy stares.frozen, a child casts toward a void;he lingers, and alights.frozen, the shadowy figure lingers.as a child casts toward a star;he alights, and kneels.momentarily the boy reflects.frozen, the boy stares at a sky;the shadowy figure alights, and pauses.momentarily the boy alights.as the shadowy figure damns a abyss;a child stares, but reflects.while she kneels.frozen, she captures the abyss;the shadowy figure stares, while waiting darkly.momentarily a child pauses.frozen, a child outlines the moon;a child stares, and pauses.frozen, a child hesitates.momentarily the shadowy figure outlines a darkness;he stares, while breathing fearfully.momentarily the boy hesitates.while the boy stares at the darkness;she returns, and reflects.momentarily the boy kneels.as she outlines a moon;she kneels, and turns away.as the shadowy figure alights.while the boy damns the darkness;a child lingers, while pointing expectantly.frozen, the shadowy figure returns.while the shadowy figure outlines the cloud;the shadowy figure hesitates, and alights.momentarily she hesitates.momentarily the boy stares at a moon;a child reflects, and kneels.as he alights.frozen, the shadowy figure casts toward the moon;the shadowy figure kneels, and kneels.while she returns.as the shadowy figure outlines a sky;she kneels, and hesitates.frozen, the shadowy figure lingers.as the boy stares at the lake;a child returns, but hesitates.frozen, he reflects.frozen, she stares at a moon;the shadowy figure returns, and hesitates.momentarily the shadowy figure pauses.momentarily he outlines a star;a child stares, while pointing darkly.frozen, the shadowy figure kneels.frozen, the boy captures the lake;the boy alights, while pointing expectantly.while a child hesitates.as he stares at the darkness;he reflects, while breathing expectantly.as the shadowy figure lingers.as a child captures the abyss;he returns, and hesitates.momentarily the boy stares.momentarily the shadowy figure casts toward a void;a child alights, and pauses.while he pauses.momentarily he captures a star;a child alights, but returns.momentarily he kneels.momentarily the shadowy figure captures the darkness;he returns, but reflects.momentarily the boy pauses.frozen, a child outlines a moon;he alights, and reflects.as he stares.as a child outlines the cloud;she hesitates, while breathing expectantly.momentarily the boy hesitates.as he stares at the lake;a child alights, and turns away.while a child stares.frozen, she captures the star;the boy reflects, and stares.while a child returns.momentarily the boy stares at the cloud;he stares, and reflects.frozen, he alights.while the boy damns a moon;the shadowy figure kneels, but lingers.while a child pauses.momentarily a child damns a void;the boy returns, and stares.frozen, the shadowy figure returns.frozen, the shadowy figure outlines a cloud;the shadowy figure stares, and pauses.while the shadowy figure hesitates.frozen, she captures a lake;she pauses, and pauses.momentarily he returns.momentarily a child casts toward the star;she stares, while breathing with fear.frozen, he lingers.as the boy casts toward a star;the shadowy figure returns, while waiting silently.while the boy stares.frozen, she captures a moon;the shadowy figure and stares.frozen, the shadowy figure reflects.momentarily the shadowy figure damns the moon;he alights, while breathing fearfully.while she lingers.while the shadowy figure outlines the moon;the shadowy figure stares, and turns away.while a child reflects.momentarily he casts toward a darkness;the shadowy figure stares, while pointing fearfully.momentarily he turns away.as he outlines the darkness;a child alights, but pauses.momentarily he pauses.frozen, a child outlines the moon;she pauses, while waiting silently.as she stares.while the shadowy figure stares at a abyss;she hesitates, but kneels.momentarily a child returns.frozen, he outlines the abyss;he pauses, while breathing darkly.momentarily a child pauses.frozen, she outlines the darkness;she returns, and pauses.as a child stares.as the boy stares at the sky;he returns, but lingers.momentarily he pauses.while a child damns the void;he turns away, while pointing fearfully.momentarily a child pauses.as she damns the abyss;the shadowy figure stares, while waiting slowly.momentarily she kneels.as she damns a lake;a child alights, but hesitates.momentarily a child reflects.momentarily the shadowy figure damns a darkness;a child turns away, and returns.while the boy alights.frozen, the boy damns a cloud;he pauses, while waiting silently.while the boy pauses.momentarily she casts toward the sky;the shadowy figure returns, and hesitates.while he pauses.momentarily she captures a sky;she hesitates, but reflects.frozen, he alights.as she damns the cloud;she lingers, but turns away.as he hesitates.momentarily the boy damns the darkness;a child returns, and hesitates.as he pauses.while she outlines a moon;a child stares, and pauses.momentarily she alights.while he casts toward a darkness;the shadowy figure stares, but returns.while the boy reflects.while she casts toward the darkness;she pauses, but turns away.momentarily he reflects.while he stares at the darkness;the boy turns away, and reflects.as the boy kneels.momentarily he casts toward a lake;she lingers, and returns.frozen, the boy hesitates.frozen, a child casts toward a abyss;the boy lingers, while pointing slowly.as the boy returns.frozen, the boy damns a cloud;the boy kneels, but kneels.as he returns.momentarily the boy outlines a darkness;the boy kneels, but kneels.momentarily he turns away.while a child captures a void;a child stares, and turns away.as he lingers.as the shadowy figure outlines a cloud;she returns, while waiting darkly.while she returns.frozen, a child damns a moon;she stares, while pointing slowly.momentarily the shadowy figure lingers.frozen, the shadowy figure outlines the lake;she hesitates, but reflects.while she returns.as a child damns the star;he hesitates, but hesitates.frozen, he lingers.while she captures the darkness;the boy alights, and pauses.momentarily she pauses.while a child stares at the lake;she reflects, but kneels.momentarily the boy alights.as the boy casts toward a star;the boy reflects, while waiting silently.while he pauses.as he damns a darkness;the shadowy figure pauses, while breathing slowly.momentarily a child lingers.momentarily she captures a abyss;the shadowy figure returns, while waiting fearfully.while she alights.frozen, the shadowy figure casts toward a darkness;the shadowy figure alights, while breathing darkly.momentarily the shadowy figure kneels.momentarily a child captures a lake;a child kneels, and turns away.momentarily a child reflects.while he casts toward a abyss;the shadowy figure alights, but alights.momentarily the shadowy figure hesitates.momentarily a child captures a moon;she turns away, and returns.as the boy stares.while he captures the lake;a child pauses, and turns away.frozen, a child alights.while a child captures the star;he turns away, but alights.while a child reflects.momentarily she outlines a abyss;the boy pauses, while breathing expectantly.frozen, a child pauses.as the shadowy figure captures a void;he alights, but alights.as the boy turns away.as she outlines a cloud;he pauses, while breathing silently.momentarily the shadowy figure turns away.frozen, she casts toward the abyss;a child hesitates, while pointing silently.frozen, he returns.frozen, he outlines the darkness;she alights, but kneels.while the shadowy figure alights.while he stares at the darkness;he reflects, and alights.as he lingers.as the boy damns the cloud;he turns away, while breathing slowly.momentarily she reflects.momentarily a child outlines a sky;he hesitates, while pointing fearfully.as the boy kneels.frozen, he casts toward a darkness;she alights, while breathing expectantly.momentarily the shadowy figure pauses.as the shadowy figure damns the void;he hesitates, but kneels.as the boy hesitates.as he damns the moon;the boy pauses, and turns away.momentarily the boy lingers.frozen, a child casts toward a sky;he alights, and kneels.frozen, she alights.while the boy stares at a star;the shadowy figure kneels, while waiting with fear.momentarily she hesitates.as the boy outlines the star;the shadowy figure kneels, and turns away.frozen, she turns away.frozen, the boy stares at the moon;she alights, but stares.while she hesitates.as she outlines a sky;the shadowy figure alights, and turns away.frozen, she alights.as she captures the sky;she kneels, and alights.momentarily the boy hesitates.frozen, a child casts toward the void;she pauses, while breathing silently.momentarily the boy lingers.frozen, the boy outlines a star;he lingers, while pointing silently.as the shadowy figure kneels.momentarily he captures a abyss;he alights, while waiting with fear.while the shadowy figure alights.momentarily she stares at the void;a child turns away, and alights.momentarily he lingers.frozen, he outlines the lake;he reflects, and turns away.while a child lingers.frozen, he outlines a lake;he lingers, and reflects.momentarily she pauses.frozen, he damns the void;a child hesitates, and lingers.frozen, the shadowy figure turns away.while she outlines the moon;she returns, while breathing silently.as the boy hesitates.frozen, he damns a darkness;the boy hesitates, while waiting with fear.momentarily the shadowy figure kneels.while he casts toward the cloud;the shadowy figure reflects, while waiting with fear.momentarily the shadowy figure reflects.momentarily a child stares at the lake;a child stares, while pointing fearfully.frozen, the boy lingers.as the shadowy figure captures the cloud;she pauses, and turns away.as the boy kneels.while she captures the lake;the boy lingers, but alights.while the shadowy figure returns.momentarily the shadowy figure outlines the cloud;a child hesitates, and reflects.frozen, she alights.momentarily he captures the star;a child hesitates, but pauses.frozen, the boy returns.as he outlines the abyss;she lingers, and hesitates.while the shadowy figure turns away.while she damns a star;a child reflects, while breathing silently.momentarily the boy stares.frozen, the boy damns the sky;the shadowy figure pauses, while waiting with fear.while he reflects.momentarily she outlines a cloud;he returns, while breathing silently.momentarily he returns.frozen, she casts toward a cloud;he kneels, while pointing with fear.frozen, she returns.momentarily the boy captures the sky;he reflects, but reflects.frozen, the boy pauses.while the boy casts toward the sky;she alights, and reflects.frozen, a child stares.frozen, he damns the lake;the boy stares, and stares.as the shadowy figure reflects.while the shadowy figure damns the darkness;a child stares, and pauses.as a child returns.while the shadowy figure stares at a void;he turns away, and kneels.frozen, a child returns.momentarily the shadowy figure stares at a cloud;the shadowy figure returns, while waiting expectantly.frozen, the shadowy figure pauses.frozen, a child damns a cloud;she hesitates, while breathing fearfully.as a child returns.as he stares at the cloud;the shadowy figure hesitates, but alights.while a child turns away.frozen, she casts toward the void;the boy hesitates, and reflects.momentarily she turns away.while she casts toward a moon;she lingers, and kneels.frozen, a child stares.frozen, she outlines a abyss;she lingers, and stares.as the shadowy figure stares.momentarily he casts toward a darkness;he lingers, and hesitates
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:bench Folder:rsg.st
+++++ Continued from previous card +++++
.frozen, the boy hesitates.momentarily the boy casts toward a moon;a child stares, and kneels.momentarily a child stares.as she damns a lake;the boy alights, and stares.frozen, the boy pauses.frozen, a child casts toward the lake;the shadowy figure lingers, and kneels.frozen, the boy stares.as the shadowy figure captures the darkness;the shadowy figure pauses, but turns away.frozen, he pauses.as a child damns the darkness;a child pauses, but kneels.while the boy stares.frozen, he damns the lake;the shadowy figure lingers, while waiting slowly.while a child alights.momentarily the shadowy figure damns the lake;the shadowy figure returns, but kneels.as she pauses.while the boy outlines a sky;he reflects, while waiting with fear.momentarily she stares.momentarily a child captures the void;she lingers, while waiting silently.as a child reflects.while the boy captures a star;he returns, and hesitates.momentarily a child reflects.frozen, a child casts toward a moon;the shadowy figure stares, but reflects.frozen, the boy pauses.while a child casts toward a lake;she kneels, while pointing silently.momentarily she stares.as she casts toward the void;the shadowy figure returns, and turns away.momentarily a child pauses.while he stares at the moon;she stares, while waiting silently.while a child stares.as the shadowy figure outlines a void;a child turns away, and alights.while the shadowy figure hesitates.frozen, the shadowy figure casts toward the abyss;she lingers, and returns.frozen, she reflects.while he stares at the star;he returns, but turns away.as a child returns.frozen, the shadowy figure damns the lake;a child pauses, but returns.frozen, he hesitates.while the shadowy figure captures a sky;he kneels, but kneels.while the shadowy figure kneels.as a child damns a sky;the shadowy figure reflects, while waiting expectantly.while a child pauses.as the shadowy figure outlines a moon;he alights, but returns.frozen, the boy lingers.as the boy casts toward the cloud;she turns away, but pauses.momentarily she reflects.momentarily she captures a cloud;the shadowy figure reflects, but stares.momentarily the boy alights.while she captures a void;he reflects, and lingers.as he turns away.momentarily the shadowy figure casts toward the star;she lingers, while pointing expectantly.frozen, the shadowy figure alights.while the shadowy figure casts toward a cloud;she hesitates, and reflects.as he lingers.as she casts toward a darkness;he turns away, and turns away.frozen, a child lingers.as the boy outlines the sky;the boy stares, and reflects.frozen, the boy turns away.momentarily the shadowy figure outlines the moon;he hesitates, but alights.while a child hesitates.while he casts toward the darkness;he lingers, but turns away.frozen, he turns away.while the shadowy figure captures a moon;the boy returns, while breathing darkly.while the shadowy figure pauses.frozen, the boy outlines a darkness;a child reflects, and hesitates.frozen, the shadowy figure lingers.as she damns a abyss;a child pauses, while breathing with fear.as he returns.while he stares at a void;he reflects, while pointing expectantly.while the shadowy figure alights.as he captures the moon;he alights, and lingers.while a child returns.as the shadowy figure casts toward the star;the boy alights, while pointing slowly.as the boy pauses.as the shadowy figure casts toward a star;a child stares, and kneels.frozen, he turns away.as he damns the void;the boy hesitates, but alights.momentarily he alights.frozen, a child outlines a lake;the boy reflects, while breathing slowly.frozen, the boy pauses.as the shadowy figure casts toward a moon;the shadowy figure alights, and stares.while the boy returns.as the boy stares at the cloud;he stares, and alights.while a child returns.as the boy captures the lake;the shadowy figure turns away, and reflects.momentarily she kneels.frozen, she stares at the star;the shadowy figure stares, and turns away.as the boy reflects.while the shadowy figure damns the cloud;she kneels, while breathing slowly.momentarily the shadowy figure turns away.momentarily the shadowy figure outlines a darkness;she returns, while pointing silently.while the shadowy figure turns away.frozen, he outlines a darkness;the shadowy figure returns, but turns away.frozen, the boy hesitates.as a child outlines a abyss;the shadowy figure lingers, and returns.while the boy pauses.while he captures a void;she lingers, and kneels.frozen, she reflects.frozen, the boy outlines a abyss;she reflects, but reflects.momentarily a child lingers.as the boy casts toward a moon;the boy reflects, and kneels.while the boy stares.as the shadowy figure outlines the darkness;he turns away, and stares.as the boy lingers.while he casts toward the star;the shadowy figure stares, and stares.momentarily the shadowy figure kneels.while he casts toward a lake;a child reflects, and pauses.as the boy hesitates.as he outlines the cloud;she reflects, while breathing silently.frozen, the boy alights.while he casts toward a darkness;she kneels, and turns away.while he stares.as she outlines the lake;the boy alights, but lingers.frozen, she alights.momentarily a child outlines a void;a child kneels, while breathing expectantly.momentarily she alights.momentarily he outlines the sky;a child stares, and returns.frozen, she reflects.while a child damns a cloud;the boy stares, but turns away.as she alights.momentarily a child stares at a void;she alights, while waiting silently.while he reflects.while the boy stares at a lake;she stares, but kneels.while the shadowy figure pauses.frozen, a child casts toward the void;she pauses, but reflects.frozen, she hesitates.frozen, a child stares at the star;a child reflects, but stares.momentarily a child reflects.while the shadowy figure damns a star;the shadowy figure alights, and returns.while he turns away.momentarily a child outlines a cloud;the shadowy figure stares, while breathing darkly.momentarily the boy returns.while the boy outlines the moon;she lingers, but alights.momentarily the boy alights.as she captures a void;she reflects, and pauses.momentarily a child lingers.momentarily she casts toward the star;the shadowy figure kneels, and lingers.frozen, a child stares.frozen, a child outlines the sky;he turns away, but pauses.as he stares.frozen, she stares at the abyss;a child returns, while breathing with fear.as she returns.momentarily the shadowy figure stares at a void;the shadowy figure alights, and hesitates.as he returns.frozen, she casts toward a star;she pauses, but stares.momentarily a child reflects.momentarily he casts toward the moon;the shadowy figure lingers, and stares.momentarily a child returns.as the boy stares at the moon;the boy reflects, and turns away.while he pauses.frozen, the boy stares at a sky;a child pauses, but kneels.momentarily the shadowy figure kneels.while the shadowy figure captures a sky;he kneels, while waiting slowly.frozen, a child pauses.as the shadowy figure outlines the abyss;a child turns away, but turns away.as the shadowy figure turns away.while he captures a abyss;she pauses, but pauses.momentarily she turns away.as the boy outlines the void;the boy kneels, while pointing silently.frozen, a child alights.as the boy damns the sky;he hesitates, and pauses.as she hesitates.momentarily she outlines a abyss;she turns away, and returns.frozen, the shadowy figure stares.frozen, a child damns the moon;a child stares, and lingers.frozen, the boy kneels.frozen, he outlines a lake;the shadowy figure stares, and reflects.while the shadowy figure returns.while a child casts toward the void;the shadowy figure kneels, but alights.momentarily a child alights.as the boy captures a darkness;she reflects, while pointing darkly.while she stares.while he casts toward a moon;the boy stares, while pointing silently.momentarily the boy returns.frozen, a child outlines the abyss;the boy pauses, while waiting fearfully.while the boy stares.as a child captures the star;he pauses, and hesitates.frozen, she lingers.frozen, she damns the star;the boy reflects, while pointing silently.momentarily the shadowy figure hesitates.while he damns the darkness;she returns, and alights.while the boy pauses.as he casts toward the void;the shadowy figure reflects, and turns away.momentarily he kneels.momentarily the shadowy figure captures the abyss;a child hesitates, and turns away.frozen, she kneels.momentarily the shadowy figure outlines the void;she alights, and hesitates.as the boy alights.momentarily the shadowy figure stares at the moon;the boy turns away, and reflects.momentarily she turns away.as she captures the abyss;he stares, but hesitates.as the shadowy figure returns.while a child outlines a lake;the shadowy figure hesitates, and lingers.as she stares.as he outlines the void;the boy stares, while pointing silently.momentarily the shadowy figure returns.frozen, the boy captures a sky;the shadowy figure returns, while pointing silently.momentarily she returns.momentarily the shadowy figure captures a abyss;the shadowy figure lingers, and lingers.while the shadowy figure reflects.as the boy damns a void;a child pauses, while waiting slowly.momentarily the boy stares.while she stares at a star;the boy returns, and pauses.momentarily the boy returns.momentarily he stares at the cloud;he alights, while breathing silently.as he reflects.momentarily the boy captures the moon;a child turns away, and turns away.momentarily the boy reflects.momentarily he stares at the abyss;the boy stares, and hesitates.momentarily he pauses.while a child casts toward the darkness;the boy returns, and returns.frozen, a child turns away.while the boy stares at a void;she stares, but lingers.as a child stares.frozen, the boy captures the darkness;the boy stares, and alights.momentarily the boy kneels.while the boy stares at the sky;the boy lingers, while pointing darkly.frozen, the shadowy figure stares.as he casts toward the abyss;the boy kneels, and stares.while he alights.frozen, the boy outlines the moon;she alights, but hesitates.while the shadowy figure turns away.momentarily a child outlines a star;he stares, and pauses.frozen, a child hesitates.frozen, he captures the darkness;a child lingers, and returns.momentarily a child returns.while the shadowy figure captures a abyss;the shadowy figure stares, and reflects.as a child turns away.frozen, the boy stares at a star;the shadowy figure alights, while breathing with fear.while the boy lingers.as he captures a abyss;she turns away, but pauses.as she hesitates.while he casts toward the void;a child returns, while breathing slowly.frozen, a child pauses.frozen, the boy captures a darkness;he turns away, and lingers.frozen, she turns away.frozen, she captures the abyss;she pauses, but stares.frozen, she kneels.frozen, a child damns a void;the shadowy figure turns away, but lingers.frozen, a child kneels.while a child casts toward the void;she stares, while waiting expectantly.frozen, she reflects.momentarily the boy casts toward a cloud;she lingers, while pointing fearfully.momentarily the shadowy figure reflects.momentarily he stares at a sky;she pauses, and returns.as she alights.frozen, the boy captures a sky;the boy pauses, but reflects.frozen, a child hesitates.frozen, he damns the abyss;a child stares, and hesitates.as she pauses.frozen, the boy casts toward the lake;the boy lingers, and pauses.while the shadowy figure lingers.as a child stares at the moon;she stares, and reflects.while a child returns.momentarily she casts toward the abyss;the shadowy figure reflects, and lingers.while a child stares.while she stares at the lake;the boy alights, and stares.as the shadowy figure returns.as a child outlines a cloud;the boy pauses, but turns away.momentarily the shadowy figure reflects.frozen, a child outlines the darkness;the shadowy figure turns away, and hesitates.frozen, the shadowy figure pauses.frozen, he outlines the lake;the boy kneels, while breathing slowly.as the boy turns away.while a child casts toward the lake;a child alights, while waiting expectantly.while she lingers.momentarily the shadowy figure casts toward the sky;the boy lingers, and pauses.frozen, a child alights.as a child damns a moon;he reflects, while waiting expectantly.while the shadowy figure alights.as a child stares at the cloud;he turns away, but alights.as she reflects.while a child captures the abyss;the boy reflects, while pointing silently.momentarily a child reflects.while a child stares at a star;the boy turns away, while pointing silently.momentarily he reflects.momentarily he stares at a cloud;the boy stares, but stares.as she reflects.momentarily the boy casts toward a sky;the shadowy figure pauses, and reflects.while the boy reflects.while a child stares at the sky;he stares, while breathing expectantly.momentarily she returns.as the boy damns the void;the boy turns away, while breathing fearfully.while he stares.frozen, the boy casts toward a lake;the shadowy figure alights, and returns.while the boy stares.as he casts toward the sky;a child turns away, but hesitates.frozen, he pauses.frozen, a child damns the lake;she lingers, while pointing darkly.as she kneels.momentarily she outlines a star;she lingers, and kneels.frozen, he reflects.while the shadowy figure damns a abyss;she returns, and kneels.momentarily he turns away.momentarily he damns a abyss;he returns, and alights.as she returns.momentarily she outlines a moon;the boy pauses, and lingers.while a child alights.momentarily he stares at the cloud;the boy lingers, and kneels.frozen, the shadowy figure kneels.while the boy outlines a sky;she kneels, and returns.while a child hesitates.frozen, the shadowy figure outlines the moon;the boy stares, and stares.frozen, the boy returns.momentarily the shadowy figure casts toward a darkness;she reflects, but stares.momentarily a child returns.as the shadowy figure casts toward the star;the shadowy figure returns, and lingers.momentarily she kneels.frozen, the boy stares at the void;she stares, but reflects.frozen, a child turns away.as he captures the void;he alights, and kneels.momentarily a child reflects.frozen, a child casts toward a lake;a child stares, and kneels.as she returns.as a child outlines the moon;a child lingers, while pointing with fear.while she alights.while she casts toward the star;a child stares, while pointing silently.while she pauses.frozen, the shadowy figure casts toward a darkness;he stares, but returns.while the shadowy figure hesitates.momentarily he damns the star;a child returns, and stares.as she returns.while she damns a lake;a child alights, and turns away.momentarily a child lingers.momentarily the boy captures a star;a child hesitates, and hesitates.momentarily the shadowy figure stares.momentarily the shadowy figure captures a star;the boy returns, while waiting slowly.momentarily she alights.as he outlines the darkness;a child kneels, while breathing darkly.as the shadowy figure reflects.as the shadowy figure damns the sky;the boy h
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:bench Folder:rsg.st
+++++ Continued from previous card +++++
esitates, and pauses.frozen, she alights.momentarily he outlines a moon;the boy pauses, and alights.momentarily the shadowy figure lingers.as a child casts toward the moon;the boy turns away, and stares.momentarily the shadowy figure hesitates.as a child casts toward a void;he alights, and hesitates.while a child stares.as a child stares at the abyss;he hesitates, but stares.momentarily a child turns away.while the boy damns the darkness;she pauses, and reflects.momentarily a child alights.while the boy casts toward a moon;the boy pauses, and hesitates.as the boy returns.momentarily she stares at the sky;a child pauses, while pointing expectantly.momentarily he hesitates.while she casts toward the moon;a child kneels, and kneels.momentarily the shadowy figure stares.momentarily the boy stares at the void;the boy alights, while pointing slowly.as he reflects.while a child casts toward the star;the shadowy figure lingers, and pauses.as she kneels. elapsed time = 32783regionsstatic 60480string 65024block 65024storagestatic 60480string 520block 35600collectionstotal 63static 0string 0block 63 :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:bench Folder:Run
############################################################################## Name: shuffle.icn## Title: Shuffle values## Author: Ward Cunningham## Date: June 10, 1988############################################################################## # The procedure shuffle(x) shuffles a string or list. In the case# that x is a string, a corresponding string with the characters# randomly rearranged is produced. In the case that x is a list,# the values in the list are randomly rearranged.# ############################################################################procedure shuffle(x) x := string(x) every !x :=: ?x return xend :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:bench Folder:Translate
for i in {"parameters"} icont -s -c "{i}"end :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:BuildIcon
## MPW Shell script to build MPW Icon V8#Set Exit 1Echo 'Building common object files…'Build common {"Parameters"}Echo 'Building icont…'Build icont {"Parameters"}Echo 'Building iconx…'Build iconx {"Parameters"}BeepConfirm 'OK to replace executables?'Exit if {Status} != 0Echo 'Replacing executables…'#Move -y "{icon}"icon[tx] "{icon}"SavedV8Duplicate -y :icont:icont "{icon}"Duplicate -y :iconx:iconx "{icon}" :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:calling Folder:callboth.icn
procedure main() write(&version) write(&host) every write(&features) write("the sin of 45 is ", callout("asinh", "45")) callout("printf", "this is a test") write("the string is 25;", " the number = ", callout("atoi", "25")) recurse(3)endprocedure recurse(n) static cnt initial cnt := 0 write("in routine recurse") write("cnt = ", cnt, "; n = ", n) cnt := cnt + 1 if (cnt < n) then callout("myroutine")endprocedure wordcount(n) local t, line, x, i static letters initial letters := &lcase ++ &ucase t := table(0) while line := read() do line ? while tab(upto(letters)) do t[tab(many(letters))] +:= 1 x := sort(t,3) every i := 1 to *x - 1 by 2 do write(left(x[i],n),x[i + 1]) return "true"endprocedure testing(n) static cnt initial cnt := 2 /n := -1 if (n < 0) then fail else if (n = 0) then return n while n > 0 do { m := cnt cnt -:= 1 suspend m }endprocedure junk() write(reverse("this is not a test")) display() write(find("is", "this is a test"))end :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:calling Folder:callin.icn
procedure main() write(&version) write(&host) every write(&features)endprocedure wordcount(n) local t, line, x, i static letters initial letters := &lcase ++ &ucase t := table(0) while line := read() do line ? while tab(upto(letters)) do t[tab(many(letters))] +:= 1 x := sort(t,3) every i := 1 to *x -do write(left(x[i],n),x[i + 1]) return "true"endprocedure testing(n) static cnt initial cnt := 2 /n := -1 if (n < 0) then fail else if (n = 0) then return n while n > 0 do { m := cnt cnt -:= 1 suspend m }endprocedure junk() write(reverse("this is not a test")) display() write(find("is", "this is a test"))end :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:calling Folder:callout.icn
procedure main() write(&version) write(&host) every write(&features) callout("printf", "this is a test") write("the string is 25;", " the number = ", callout("atoi", "25"))end :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:calling Folder:extcall.c
/* * Example of calling C functions by integer codes. Here it's * one of three UNIX functions: * * 1: getpid (get process identification) * 2: getppid (get parent process identification) * 3: getpgrp (get process group) */#include "../h/config.h"#include "../h/rt.h"#include "rproto.h"struct descrip retval; /* for returned value */dptr extcall(dargv, argc, ip)dptr dargv;int argc;int *ip; { int retcode; int getpid(), getppid(), getpgrp(); *ip = -1; /* anticipate error-free execution */ if (cvint(dargv) == CvtFail) { /* 1st argument must be a string */ *ip = 101; /* "integer expected" error number */ return dargv; /* return offending value */ } switch ((int)IntVal(*dargv)) { case 1: /* getpid */ retcode = getpid(); break; case 2: /* getppid */ retcode = getppid(); break; case 3: /* getpgrp */ if (argc < 2) { *ip = 205; /* no error number fits, really */ return NULL; /* no offending value */ } dargv++; /* get to next value */ if (cvint(dargv) == CvtFail) { /* 2nd argument must be integer */ *ip = 101; /* "integer expected" error number */ return dargv; } retcode = getpgrp(IntVal(*dargv)); break; default: *ip = 216; /* external function not found */ return NULL; } MakeInt(retcode,&retval); /* make an Icon integer for result */ return &retval; } :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:calling Folder:extname.c
/* * Example of calling C functions by their names. Here it's just * chdir (change directory) or getwd (get path of current working directory). */#include "../h/config.h"#include "../h/rt.h"#include "rproto.h"struct descrip retval; /* for returned value */dptr extcall(dargv, argc, ip)dptr dargv;int argc;int *ip; { int len, retcode; char sbuf1[MaxCvtLen]; /* for conversion on non-strings */ char sbuf2[MaxCvtLen]; /* for C-style string */ int chdir(), getwd(); *ip = -1; /* anticipate error-free execution */ if (cvstr(dargv, sbuf1) == CvtFail) { /* 1st argument must be a string */ *ip = 103; /* "string expected" error number */ return dargv; /* return offending value */ } if (strncmp("chdir", StrLoc(*dargv), StrLen(*dargv)) == 0) { if (argc < 2) { /* must be a 2nd argument */ *ip = 103; /* no error number fits, really */ return NULL; /* no offedning value */ } dargv++; /* get to next argument */ if (cvstr(dargv, sbuf1) == CvtFail) { /* 2nd argument must be a string */ *ip = 103; /* "string expected" error number */ return dargv; /* return offending value */ } qtos(dargv,sbuf2); /* get C-style string in sbuf2 */ retcode = chdir(sbuf2); /* try to change directory */ if (retcode == -1) /* see if chdir failed */ return (dptr)NULL; /* signal failure */ return &zerodesc; /* not a very useful result */ } else if (strncmp("getwd", StrLoc(*dargv), StrLen(*dargv)) == 0) { dargv++; /* get to next argument */ retcode = getwd(sbuf2); /* get current working directory */ if (retcode == 0) /* see if getwd failed */ return NULL; /* signal failure */ len = strlen(sbuf2); /* length of resulting string */ if (strreq(len) == Error) { /* need to allocate a copy of result */ *ip = 0; /* zero since code is set elsewhere */ return (dptr)NULL; /* no offending value */ } StrLoc(retval) = alcstr(sbuf2,len); /* allocate and copy the string */ StrLen(retval) = len; return &retval; /* return a pointer to the qualifier */ } else { *ip = 216; /* name is not one of those supported here */ return dargv; /* return pointer to offending value */ } } :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:calling Folder:iconval.c
/* * Demonstration program to call an Icon procedure with arguments. This * program is used as * * iconval iprog proc arg1 arg2 ... * * where iprog is the name of the Icon icode file, proc is the name of * a procedure in it, and arg1, arg2, ... are arguments passed to proc. * It prints out the result if proc succeeds or notes if the procedure fails. * It prints a diagnostic message if proc is not a procedure in iprog. */#include "../h/config.h"#include "../h/rt.h"#include "rproto.h"extern int call_error;novalue main(argc,argv)int argc;char *argv[]; { int clargc; char **clargv; dptr retval, iargv; int i; char sbuf[MaxCvtLen]; /* * Read in the icode file argv[1] and initialize the Icon system. * This must be done for any C program calling Icon. */ icon_init(argv[1]); /* * Skip the names of the executable and the file it processes. It * is only necessary to get the the procedure name and its arguments from * the command line. */ clargv = argv + 2; clargc = argc - 3; fprintf(stderr,"program=%s\n",*clargv); fflush(stderr); /* * Malloc space for the list of descriptors and create Icon qualifiers * for each argument. */ iargv = (dptr)malloc(clargc * sizeof(struct descrip)); for (i = 0; i < clargc; i++) { StrLoc(iargv[i]) = clargv[i + 1]; StrLen(iargv[i]) = strlen(clargv[i + 1]); } retval = icon_call(*clargv, clargc, iargv); if (call_error) { fprintf(stderr,"procedure not found\n"); fflush(stderr); c_exit(ErrorExit); } if (retval == NULL) fprintf(stdout,"evaluation failed\n"); else { /* Check type of result returned. Don't attempt to print anything * but strings and integers here. */ if (Qual(*retval)) { qtos(retval,sbuf); fprintf(stdout,"\"%s\"\n",sbuf); } else if (Type(*retval) == T_Integer) fprintf(stdout,"%ld\n",IntVal(*retval)); else fprintf(stdout,"type=%d\n",Type(*retval)); fflush(stdout); } c_exit(NormalExit); } :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:calling Folder:istart.c
/* * Main program if Icon is called as a subprogram. */#include "../h/config.h"#include "../h/rt.h"#include "rproto.h"#ifdef IconCallingnovalue main(argc,argv)int argc;char *argv[]; { int clargc; char **clargv; int i; struct descrip darg; /* * Set up standard Icon interface. This is only necessary so that * Icon can behave normally as if it were the main program. * It is not necessary if Icon is called by a C program for another * purpose. */ icon_setup(argc, argv, &i); while (i--) { /* skip option arguments */ argc--; argv++; } if (!argc) error("no icode file specified"); /* * Read in the icode file argv[1] and initialize the Icon system. * This done for any C program calling Icon. */ icon_init(argv[1]); /* * Skip the names of the executable and the file it processes. This * is necessary only to get the right arguments from the command line * to call Icon as if it were the main program and hence provide * the correct values in the list that is the argument of Icon's main * procedure. This is not necessary if Icon is called from C for * another purpose. */ clargv = argv + 2; clargc = argc - 2; /* * Set up a temporary stack and build the necessary list * to call main. */ sp = stack + Wsizeof(struct b_coexpr); PushNull; argp = (dptr)(sp - 1); for (i = 0; i < clargc; i++) { PushAVal(strlen(clargv[i])); PushVal(clargv[i]); } Ollist(clargc, argp); /* * Now that the list is computed, copy its descriptor off the * stack (which is about to be destroyed), reset the argument * pointer, and make the call to the Icon main procedure. */ darg = *argp; argp = 0; icon_call("main", 1, &darg); /* return signal and value ignored */ c_exit(NormalExit); }#else /* IconCalling */static char x; /* avoid empty module */#endif /* IconCalling */ :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:calling Folder:Makefile
what: ### echo "What do you want to make?"Clean: delete ≈.o :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:common Folder:cproto.h
/* * cproto.h -- prototypes for functions common to several modules. */novalue getctime Params((char *sbuf));int getopt Params((int nargs, char **nargv, char *ostr));novalue getitime Params((struct cal_time *ct));long longwrite Params((char *s,long len,FILE *file));long lstrlen Params((char *s));#ifndef memcopypointer memcopy Params((char *to, char* from, word n));#endif#ifndef memfillpointer memfill Params((char *to, int con, word n));#endiflong millisec Params((noargs));int tonum Params((int c)); :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:common Folder:ebcdic.c
/* * memory.c -- functions to copy and fill memory. */#include "::h:config.h"pointer memcopy(to, from, n) register char *to, *from; register word n; { register char *p = to; while (--n >= 0) *to++ = *from++; return (pointer)p; }pointer memfill(to, con, n) register char *to; register con; register word n; { register char *p = to; while (--n >= 0) *to++ = con; return (pointer)p; } :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:common Folder:save.c
/* * save(s) -- for systems that support ExecImages */#include "::h:config.h"#ifdef ExecImages/* * save(s) -- for the Convex. */#ifdef CONVEX#define TEXT0 0x80001000 /* address of first .text page */#define DATA0 ((int) &environ & -4096) /* address of first .data page */#define START TEXT0 /* start address */#include <convex/filehdr.h>#include <convex/opthdr.h>#include <convex/scnhdr.h>extern char environ;wrtexec (ef)int ef;{ struct filehdr filehdr; struct opthdr opthdr; struct scnhdr texthdr; struct scnhdr datahdr; int foffs = 0; int ooffs = foffs + sizeof filehdr; int toffs = ooffs + sizeof opthdr; int doffs = toffs + sizeof texthdr; int tsize = DATA0 - TEXT0; int dsize = (sbrk (0) - DATA0 + 4095) & -4096; bzero (&filehdr, sizeof filehdr); bzero (&opthdr, sizeof opthdr); bzero (&texthdr, sizeof texthdr); bzero (&datahdr, sizeof datahdr); filehdr.h_magic = SOFF_MAGIC; filehdr.h_nscns = 2; filehdr.h_scnptr = toffs; filehdr.h_opthdr = sizeof opthdr; opthdr.o_entry = START; opthdr.o_flags = OF_EXEC | OF_STRIPPED; texthdr.s_vaddr = TEXT0; texthdr.s_size = tsize; texthdr.s_scnptr = 0x1000; texthdr.s_prot = VM_PG_R | VM_PG_E; texthdr.s_flags = S_TEXT; datahdr.s_vaddr = DATA0; datahdr.s_size = dsize; datahdr.s_scnptr = 0x1000 + tsize; datahdr.s_prot = VM_PG_R | VM_PG_W; datahdr.s_flags = S_DATA; write (ef, &filehdr, sizeof filehdr); write (ef, &opthdr, sizeof opthdr); write (ef, &texthdr, sizeof texthdr); write (ef, &datahdr, sizeof datahdr); lseek (ef, 0x1000, 0); write (ef, TEXT0, tsize + dsize); close (ef); return dsize;}#endif /* CONVEX */ /* * save(s) -- for generic BSD systems. */#ifdef GenericBSD#include <a.out.h>wrtexec(ef)int ef;{ struct exec hdr; extern environ, etext; int tsize, dsize; /* * Construct the header. The text and data region sizes must be multiples * of 1024. */ hdr.a_magic = ZMAGIC; tsize = (int)&etext; hdr.a_text = (tsize + 1024) & ~(1024-1); dsize = sbrk(0) - (int)&environ; hdr.a_data = (dsize + 1024) & ~(1024-1); hdr.a_bss = 0; hdr.a_syms = 0; hdr.a_entry = 0; hdr.a_trsize = 0; hdr.a_drsize = 0; /* * Write the header. */ write(ef, &hdr, sizeof(hdr)); /* * Write the text, starting at N_TXTOFF. */ lseek(ef, N_TXTOFF(hdr), 0); write(ef, 0, tsize); lseek(ef, hdr.a_text - tsize, 1); /* * Write the data. */ write(ef, &environ, dsize); lseek(ef, hdr.a_data - dsize, 1); close(ef); return hdr.a_data;}#endif /* GenericBSD */ /* * save(s) -- for the Encore.*/#ifdef MULTIMAX#include <time.h>#include <a.out.h>#include <sys/file.h>#include <sgs.h>#define NUMSECS 2 /* Two sections in the image. */#define TEXTSTART 0 /* Text starts at address 0. */#define MODSTART 0x20 /* Depends on crt0.s */#define MODSIZE 0x10 /* Depends on crt0.s */#define IMAGEPAGE 4096 /* Page size for images. Found it */ /* with aoutdump(1) */#define HDRSIZE (sizeof(struct filehdr)+sizeof(struct aouthdr)+ \ NUMSECS*sizeof(struct scnhdr))#define PAGEROUND(x) (((x+IMAGEPAGE-1)/IMAGEPAGE)*IMAGEPAGE)extern etext; /* ld(1) puts this at the end of the text segment. */extern environ; /* ld(1) puts this at the start of the data segment. *//* * wrtexec() - save image in file. */wrtexec(ExecFile) int ExecFile;{ int Status; /* For saving status codes. */ /* Call internal wrtexec2() routine. */ Status=wrtexec2(ExecFile); /* Close the file. */ close(ExecFile); return Status;}/* * wrtexec2 - Code to write the image file. */staticwrtexec2(ExecFile) int ExecFile;{ struct filehdr FileHeader; /* File header record. */ struct aouthdr SystemHeader; /* System header record. */ struct scnhdr SectionHeader; /* Section header record. */ struct timeval TV; /* Time value. */ struct timezone TZ; /* Time zone. */ unsigned long TextStart; /* Start of text. */ unsigned long TextSize; /* Size of text. */ unsigned long TextFPtr; /* Location of text in image file. */ unsigned long DataStart; /* Start of data. */ unsigned long DataSize; /* Size of data. */ unsigned long DataFPtr; /* Location of data in image file. */ /* Figure out a few things we need to know. */ TextStart = TEXTSTART; TextSize = (unsigned long)&etext; TextFPtr = PAGEROUND(HDRSIZE); DataStart = (unsigned long)&environ; DataSize = sbrk(0)-DataStart; DataFPtr = TextFPtr+PAGEROUND(TextSize); /* Write a file header. */ FileHeader.f_magic = NS32GMAGIC; /* NS 32k executable. */ FileHeader.f_nscns = NUMSECS; /* Three standard sections. */ gettimeofday(&TV,&TZ); FileHeader.f_timdat = TV.tv_sec; /* Time stamp. */ FileHeader.f_symptr = 0; /* No symbols. */ FileHeader.f_nsyms = 0; /* No symbols. */ FileHeader.f_opthdr = sizeof(struct aouthdr); /* Size of system header. */ FileHeader.f_flags = F_RELFLG|F_EXEC|F_LNNO|F_LSYMS; /* Misc. Flags. */ if(write(ExecFile,&FileHeader,sizeof FileHeader)==-1) return -1; /* Write a system header. */ SystemHeader.magic = PAGEMAGIC; /* Normal executable. */ SystemHeader.vstamp = 0; /* Ignore this. */ SystemHeader.tsize = TextSize; /* Size of text segment. */ SystemHeader.dsize = DataSize; /* Size of data segment. */ SystemHeader.bsize = 0; /* No bss */ SystemHeader.msize = MODSIZE; /* Magic from aoutdump(1). */ SystemHeader.mod_start = MODSTART; /* Magic from aoutdump(1). */ SystemHeader.entry = 0x2; /* Magic from aoutdump(1). */ SystemHeader.text_start = TextStart; /* Magic from aoutdump(1). */ SystemHeader.data_start = DataStart; /* Start of data segment. */ SystemHeader.entry_mod = 0; /* Unused. */ SystemHeader.flags = U_SYS_42|U_AL_4096; /* UMAX 4.2, 4k align. */ if(write(ExecFile,&SystemHeader,sizeof SystemHeader)==-1) return -1; /* Write text section header. */ strcpy(SectionHeader.s_name,_TEXT); /* Section name. */ SectionHeader.s_paddr = TextStart; /* Physical address. */ SectionHeader.s_vaddr = TextStart; /* Virtual address. */ SectionHeader.s_size = TextSize; /* Section size. */ SectionHeader.s_scnptr = TextFPtr; /* File ptr to section. */ SectionHeader.s_relptr = 0; /* No relocation data. */ SectionHeader.s_lnnoptr = 0; /* No line numbers. */ SectionHeader.s_nreloc = 0; /* No relocation data. */ SectionHeader.s_nlnno = 0; /* No line numbers. */ SectionHeader.s_flags = STYP_TEXT; /* Text section. */ SectionHeader.s_symptr = 0; /* No symbol data. */ SectionHeader.s_modno = 0; /* Ignore this. */ SectionHeader.s_pad = 0; /* Padding. */ if(write(ExecFile,&SectionHeader,sizeof SectionHeader)==-1) return -1; /* Write data section header. */ strcpy(SectionHeader.s_name,_DATA); /* Section name. */ SectionHeader.s_paddr = DataStart; /* Physical address. */ SectionHeader.s_vaddr = DataStart; /* Virtual address. */ SectionHeader.s_size = DataSize; /* Section size. */ SectionHeader.s_scnptr = DataFPtr; /* File ptr to section. */ SectionHeader.s_relptr = 0; /* No relocation data. */ SectionHeader.s_lnnoptr = 0; /* No line numbers. */ SectionHeader.s_nreloc = 0; /* No relocation data. */ SectionHeader.s_nlnno = 0; /* No line numbers. */ SectionHeader.s_flags = STYP_DATA; /* Data section. */ SectionHeader.s_symptr = 0; /* No symbol data. */ SectionHeader.s_modno = 0; /* Ignore this. */ SectionHeader.s_pad = 0; /* Padding. */ if(write(ExecFile,&SectionHeader,sizeof SectionHeader)==-1) return -1; /* Write the text section. */ if(lseek(ExecFile,TextFPtr,L_SET)==-1) return -1; if(write(ExecFile,TextStart,TextSize)==-1) return -1; /* Write the data section. */ if(lseek(ExecFile,DataFPtr,L_SET)==-1) return -1; if(write(ExecFile,DataStart,DataSize)==-1) return -1; return DataSize;}#endif /* MULTIMAX */ /* * save(s) -- for Sun Workstations. */#ifdef SUN#include <a.out.h>wrtexec(ef)int ef;{ struct exec *hdrp, hdr; extern environ, etext; int tsize, dsize; hdrp = (struct exec *)PAGSIZ; /* * This code only handles the ZMAGIC format... */ if (hdrp->a_magic != ZMAGIC) syserr("executable is not ZMAGIC format"); /* * Construct the header by copying in the header in core and fixing * up values as necessary. */ hdr = *hdrp; tsize = (char *)&etext - (char *)hdrp; hdr.a_text = (tsize + PAGSIZ) & ~(PAGSIZ-1); dsize = sbrk(0) - (int)&environ; hdr.a_data = (dsize + PAGSIZ) & ~(PAGSIZ-1); hdr.a_bss = 0; hdr.a_syms = 0; hdr.a_trsize = 0; hdr.a_drsize = 0; /* * Write the text. */ write(ef, hdrp, tsize); lseek(ef, hdr.a_text, 0); /* * Write the data. */ write(ef, &environ, dsize); lseek(ef, hdr.a_data - dsize, 1); /* * Write the header. */ lseek(ef, 0, 0); write(ef, &hdr, sizeof(hdr)); close(ef); return hdr.a_data;}#endif /* SUN */#else /* ExecImages */static char junk;#endif /* ExecImages */ :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:common Folder:time.c
#include "::h:config.h"/* * The following code is operating-system dependent [@time.01]. Include files * that are system-dependent. */#if PORT /* probably needs something */Deliberate Syntax Error#endif /* PORT */#if AMIGA#include "time.h"#endif /* AMIGA */#if ATARI_ST /* nothing is needed */#endif /* ATARI_ST */#if HIGHC_386 || MVS || VM#include <time.h>#endif /* HIGHC_386 || MVS || ... */#if MACINTOSH#if LSC#include <time.h>#endif /* LSC */#if MPW#include <types.h>#include "time.h"#include <OSUtils.h>#include <Events.h>#endif /* MPW */#endif /* MACINTOSH */#if MSDOS#include <time.h>#if MICROSOFT#include <sys/types.h>#endif /* MICROSOFT */#endif /* MSDOS */#if OS2#include <time.h>#include <sys/types.h>#endif /* OS2 */#if UNIX#include <sys/types.h>#include <sys/times.h>#include SysTime#endif /* UNIX */#if VMS#include <types.h>#include <time.h>struct tms { time_t tms_utime; /* user time */ time_t tms_stime; /* system time */ time_t tms_cutime; /* user time, children */ time_t tms_cstime; /* system time, children */};#endif /* VMS *//* * End of operating-system specific code. */static char *day[] = { "Sunday", "Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday" };static char *month[] = { "January", "February", "March", "April", "May", "June", "July", "August", "September", "October", "November", "December" };/* * getitime - fill in a "struct cal_time" with information about the current * time and date. */novalue getitime(ct)struct cal_time *ct; {/* * The following code is operating-system dependent [@time.02]. Declarations * for getting time. */#if PORT long time(); long xclock;Deliberate Syntax Error#endif /* PORT */#if AMIGA || OS2 || UNIX || VMS long time(); long xclock;#endif /* AMIGA || OS2 || UNIX || VMS */#if ATARI_ST struct tm { short tm_year; short tm_mon; short tm_wday; short tm_mday; short tm_hour; short tm_min; short tm_sec; }; long xclock;#endif /* ATARI_ST */#if MSDOS long xclock;#if LATTICE || MICROSOFT || TURBO long time();#endif /* LATTICE || MICROSOFT || TURBO */#if MWC time_t time();#endif /* MWC */#endif /* MSDOS */#if HIGHC_386 long time(); time_t xclock;#endif /* HIGHC_386 */#if MACINTOSH#if LSC unsigned long xclock; unsigned long time();#else /* LSC */ time_t xclock;#endif /* LSC */#endif /* MACINTOSH */#if MVS || VM time_t xclock;#endif /* MVS || VM *//* * End of operating-system specific code. */ struct tm *tbuf, *localtime();/* * The following code is operating-system dependent [@time.03]. Code for * getting time. */#if PORT time(&xclock); tbuf = localtime(&xclock);Deliberate Syntax Error#endif /* PORT */#if AMIGA || HIGHC_386 || MACINTOSH || MSDOS || OS2 || UNIX || VMS || MVS || VM time(&xclock); tbuf = localtime(&xclock);#endif /* AMIGA || HIGHC || ... */#if ATARI_ST tbuf = localtime(&xclock);#endif /* ATARI_ST *//* * End of operating-system specific code. */ ct->year = 1900 + tbuf->tm_year; ct->month_no = tbuf->tm_mon+1; ct->month_nm = month[tbuf->tm_mon]; ct->mday = tbuf->tm_mday; ct->wday = day[tbuf->tm_wday]; ct->hour = tbuf->tm_hour; ct->minute = tbuf->tm_min; ct->second = tbuf->tm_sec; return; }/* * getctime - fill a buffer with the "ctime" representation of the current * time and date. The buffer must be at least 26 characters. */novalue getctime(sbuf)char *sbuf; { struct cal_time ct; getitime(&ct); sprintf(sbuf, "%.3s %.3s%3d %.2d:%.2d:%.2d %d\n", ct.wday, ct.month_nm, ct.mday, ct.hour, ct.minute, ct.second, ct.year); return; }/* * millisec - returns execution time in milliseconds. Time is measured * from the fucntions's first call. The granularity of the time is * generally more than one millisecond and on some systems it my only * be accurate to the second. */long millisec() { static int first_time = 1;/* * The following code is operating-system dependent [@time.04]. Declarations * that are system-dependent. */#if PORT static long starttime; long time();Deliberate Syntax Error#endif /* PORT */#if AMIGA || ATARI_ST || OS2 static long starttime; long time();#endif /* AMIGA || ATARI_ST || OS2 */#if MSDOS static long starttime;#if LATTICE || MICROSOFT || TURBO long time();#endif /* LATTICE || MICROSOFT || TURBO */#if MWC time_t time();#endif /* MWC */#endif /* MSDOS */#if HIGHC_386 static time_t hc_strtime; time_t hc_curtime; long time();#endif /* HIGHC_386 */#if MACINTOSH || MVS || VM static long starttime;#endif /* MACINTOSH || MVS || VM */#if UNIX || VMS struct tms tp; static long starttime;#endif /* UNIX || VMS *//* * End of operating-system specific code. */ if (first_time) { first_time = 0;/* * The following code is operating-system dependent [@time.05]. Get start * time. */#if PORT /* needs something */Deliberate Syntax Error#endif /* PORT */#if AMIGA || ATARI_ST || MSDOS || OS2 time(&starttime); /* note: this obtains time in various units */#endif /* AMIGA || ATARI_ST || MSDOS */#if HIGHC_386 time(&hc_strtime);#endif /* HIGHC_386 */#if MACINTOSH starttime = TickCount(); /* 60 ticks / secondif /* MACINTOSH */#if MVS || VM starttime = (long)clock(); /* microseconds */#endif /* MVS || VM */#if UNIX || VMS times(&tp); starttime = tp.tms_utime;#endif /* UNIX || VMS *//* * End of operating-system specific code. */ return 0L; } else { /* not first time *//* * The following code is operating-system dependent [@time.06]. Get time. */#if PORT /* needs something */Deliberate Syntax Error#endif /* PORT */#if AMIGA || MSDOS || OS2 return 1000 * (time(NULL) - starttime);#endif /* AMIGA || MSDOS || OS2 */#if ATARI_ST return (time(NULL) - starttime) / 10;#endif /* ATARI_ST */#if HIGHC_386 time(&hc_curtime); return 1000 * (long)difftime(hc_curtime,hc_strtime);#endif /* HIGHC_386 */#if MACINTOSH return 1000 * ((extended)(TickCount() - starttime) / (extended)Hz);#endif /* MACINTOSH */#if MVS || VM return ((long)clock() - starttime) / 1000;#endif /* MVS || VM */#if UNIX || VMS times(&tp); return 1000 * ((tp.tms_utime - starttime) / (double)Hz);#endif /* UNIX || VMS *//* * End of operating-system specific code. */ } } :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:docs Folder:Benchmarking
Benchmarking Version 8 of Icon Ralph E. Griswold Department of Computer Science, The University of Arizona Benchmarks of Icon programs provide interesting comparisons ofthe performance of different computer systems [1]. A suite of representative Version 8 Icon programs has beenassembled to provide uniform benchmarks over the range of comput-ers on which Icon has been implemented. Tools are provided sothat testing is largely automatic. The benchmark programs do not require any ``optional''features, such as co-expressions, and they work with the sameregions sizes on implementations of Icon with either fixed orexpandable memory regions. Input and output normally aresuppressed to avoid factors like disk speed from affecting theresults. The benchmark programs, taken from the Icon program library[2], are: concord.icn Simple word concordance; string analysis and synthesis with table manipulation. deal.icn Randomly selected bridge hands; string synthesis with mapping. ipxref.icn Icon program cross reference; string analysis and synthesis with list manipulation. queens.icn: Solutions to the non-attacking n-queens problem; goal-directed evaluation and string synthesis. rsg.icn: Random sentence generation; string synthesis with list and table manipulation. The procedures that are used to support benchmarking arelisted in Appendix A. A Makefile for running the benchmarks islisted in Appendix B. The benchmark suite is available in a variety of formats fordifferent computer systems. It includes a form for reportingresults to the Icon Project [3].IPD115b - 1 - March 8, 1990References1. R. E. Griswold and M. T. Griswold, Icon Newsletter 31, Nov. 1989.2. R. E. Griswold, The Icon Program Library, The Univ. of Arizona Tech. Rep. 90-7, 1990.3. R. E. Griswold, Version 8 Icon Benchmark Report, The Univ. of Arizona Icon Project Document IPD116, 1989.IPD115b - 2 - March 8, 1990 Appendix A - Support Procedures################################################################### Support procedures for Icon benchmarking.#################################################################### The code to be times is bracketed by calls to Init__(name)# and Term__(), where name is used for tagging the results.# The typical usage is:## procedure main()# [declarations]# Init__(name)# .# .# .# Term__()# end## If the environment variable OUTPUT is set, program output is# not suppressed.##################################################################global Save__, Saves__, Name__# List information before running.#procedure Init__(prog) Name__ := prog # program name Signature__() # initial information Regions__() Time__() if getenv("OUTPUT") then { # if OUTPUT is set, allow output write("*** Benchmarking with output ***") return } Save__ := write # turn off output Saves__ := writes write := writes := 1 returnendIPD115b - 3 - March 8, 1990# List information at termination.procedure Term__() if not getenv("OUTPUT") then { # if OUTPUT is not set, restore output write := Save__ writes := Saves__ } # final information write(Name__," elapsed time = ",Time__()) Regions__() Storage__() Collections__() returnend# List garbage collections performed.#procedure Collections__() static labels local collections initial labels := ["total","static","string","block"] collections := [] every put(collections,&collections) write("collections") every i := 1 to *labels do write(labels[i],right(collections[i],8)) returnend# List region sizes.#procedure Regions__() static labels local regions initial labels := ["static","string","block"] regions := [] every put(regions,®ions) write("regions") every i := 1 to *labels do write(labels[i],right(regions[i],8)) returnendIPD115b - 4 - March 8, 1990# List relveant implementation information#procedure Signature__() write(&version) write(&host) every write(&features) returnend# List storage used.#procedure Storage__() static labels local storage initial labels := ["static","string","block"] storage := [] every put(storage,&storage) write("storage") every i := 1 to *labels do write(labels[i],right(storage[i],8)) returnend# List elapsed time.#procedure Time__() static lasttime initial lasttime := &time return &time - lasttimeendIPD115b - 5 - March 8, 1990 Appendix B - Makefile for Benchmarking######################################################################## Makefile for Version 8 Icon benchmarking.######################################################################### In order for benchmark results to be compared meaningfully with# those from other systems, the string and block regions must be set to# 65,000 bytes. This is the normal default.## To run the benchmarks, use## make benchmark## This creates .out files with benchmark results and lists the timings.## On systems where timing varies with load or other factors, use## make rerun## which reruns the benchmarks and appends the results to the .out files.######################################################################### Program output normally is suppressed. To get program output, set# the environment variable OUTPUT. The ``expected'' output (modulo# timing differences), is in files .std for comparison. (These files# are not included with all disributions because of their large size.)#######################################################################SHELL=/bin/shwhat: @echo "What do you want to make?"benchmark: # do the whole thing make translate compile run checktranslate: # create ucode files for linking icont -s -c post icont -s -c options icont -s -c shuffleIPD115b - 6 - March 8, 1990compile: # compile the benchmark programs icont -s concord icont -s deal icont -s ipxref icont -s queens icont -s rsgrun: # run the programs echo Running concord ... iconx concord <concord.dat >concord.out echo Running deal ... iconx deal -h 500 >deal.out echo Running ipxref ... iconx ipxref <ipxref.icn >ipxref.out echo Running queens ... iconx queens -n9 >queens.out echo Running rsg ... iconx rsg <rsg.dat >rsg.outrerun: # rerun the benchmarks echo Running concord ... iconx concord <concord.dat >>concord.out echo Running deal ... iconx deal -h 500 >>deal.out echo Running ipxref ... iconx ipxref <ipxref.icn >>ipxref.out echo Running queens ... iconx queens -n9 >>queens.out echo Running rsg ... iconx rsg <rsg.dat >>rsg.outcheck: grep elapsed *.outIPD115b - 7 - March 8, 1990 :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:docs Folder:C Interfaces
Icon-C Interfaces* Ralph E. Griswold TR 90-8b January 1, 1990; last revised March 11, 1990 Department of Computer Science The University of Arizona Tucson, Arizona 85721*This work was supported by the National Science Foundation underGrant CCR-8713690. Icon-C Interfaces1.__Introduction Version 8 of Icon [1] supports two complementary features forcalling C functions from Icon and vice versa. The two facilitiesare independent, but they may be used in conjunction and recur-sively. In their simplest form, these facilities can be used with onlya little knowledge of how Icon is implemented. Sophisticateduses, however, require a good working knowledge of Icon datastructures and Icon's internal operation [2,3].2.__External_Functions The Icon function callout(x0, x1, ..., xn) allows C functionsto be called from Icon programs. The first argument, x0, desig-nates the C function to be called. The remaining arguments ofcallout() are supplied to the C function (possibly in modifiedform). The method of specifying C functions varies with systemand application. In order to provide the necessary flexibility,callout() in turn calls a C function extcall(), which has theprototype dptr extcall(dptr argv, int argc, int *ip)where argv is a pointer to an array of descriptors containing thearguments, argc is the number of arguments, and ip is a pointerto an integer status code. The value returned by extcall() is apointer to a descriptor if the computation is successful or NULLif it fails (which causes callout() to fail). A stub for extcall() is provided. It should be replaced by anappropriate C function. Alternatively, the Icon function cal-lout() can be modified to avoid the intermediate function call.Designating_C_Functions A simple mechanism for designating C functions is to associatean integer with each one that can be called and use a C switchstatement in extcall() to select the desired one. This method isused in the first example in Appendix A. A better method is touse string names, as illustrated by the second function in Appen-dix A. On most systems, all the C functions to be called must belinked with Icon (presumably through references in extcall()). Ona system like OS/2 that supports run-time dynamic linking, C - 1 -functions can be loaded as needed during program execution.Data_Interface The data interface also has to be handled by extcall() (or itsequivalent). Arguments provided by Icon are in its descriptorformat. Icon contains conversion facilities in its repertoire ofmacros and utility functions. Some that may be useful in exter-nal functions are: cvint(dp) Converts the value in the descriptor pointed to by dp to an integer, returning CvtFail if the conversion cannot be performed. IntVal(d) Accesses the (long) integer value of the integer descriptor d. MakeInt(i,dp). Constructs a integer descriptor pointed to by dp from the (long) integer i. cvstr(dp,sbuf) Converts the value in the descriptor pointed to by dp to a string in sbuf, returning CvtFail if the conversion cannot be per- formed. Qual(d) Tests if d is a descriptor for a string. StrLen(d) Accesses the length of the string in the descriptor d. StrLoc(d) Accesses the address of the string in the descriptor d. qtos(dp,sbuf) Constructs a C-style string from the descrip- tor pointed to by dp, placing it in sbuf, a buffer of length MaxCvtLen, if it is small enough or in the allocated string region if it is not. strreq(i) Requests i characters of space in the allo- cated string region, returning Error if the space is not available. alcstr(sbuf,i) Copies the string of length i in sbuf to the allocated string region. blkreq(i) Requests i bytes of space in the allocated block region, returning Error if the space is not available. cvreal(dp) Converts the value in the descriptor pointed to by dp to a real number (floating-point double), returning CvtFail if the conversion fails. - 2 - makereal(r,dp) Constructs a real-number block for r and places a pointer to it in the descriptor pointed to by dp). GetReal(dp,r) Places the floating-point double from the descriptor pointed to by dp into r. Conversion between Icon's structure values and C structs ismore complicated and must be handled on a case-by-case basis. There are several global descriptors that may be useful inexternal functions: nulldesc descriptor for the null value zerodesc descriptor for the Icon integer 0 onedesc descriptor for the Icon integer 1 emptystr descriptor for the empty stringSee iconx/idata.c for others.Error_Handling The status code pointed to by ip is used for error handling.It is -1 when extcall() is called, indicating the absence of anerror. If an error occurs in extcall(), the status code should beset to the number of an Icon run-time error [1]. Error 216should be used if the designated C function is not found. In some cases the error number is set by a utility routine(strreq() is an example). In such cases, the status code shouldbe set to zero. If there is a descriptor associated with theerror, a pointer to that descriptor should be returned by ext-call(). If there is no specific descriptor associated with theerror, extcall() should return NULL. See the examples in AppendixA. If the status code is not -1 when extcall() returns, callout()terminates program execution with a run-time error messagecorresponding to the value of the status code.3.__Calling_Icon_from_a_C_Program The C function icon_call(), which is contained in Icon, is thecomplement of the Icon function callout(). The prototype foricon_call() is dptr icon_call(char *id, int nargs, dptr argv)where id is the string name of a procedure in the Icon program tobe run and nargs is the number of descriptors in the array argv.The procedure is called with the specified arguments. The valuereturned is a pointer to the descriptor produced by the procedureif it returns or suspends, or NULL if the procedure fails. The - 3 -global variable call_error is set to a nonzero value if the pro-cedure is not found. See Appendix B for examples. Before icon_call() is called the first time, Icon must be ini-tialized by calling icont_init(prog), where prog is the name ofthe icode file to be run. This loads the named icode file, setsup Icon's storage regions, and readies Icon for execution. Subse-quently, icon_call() can be called repeatedly.4.__Compiling_Icon_for_C_Calling External functions (callout()) normally are enabled when Iconis compiled. They can be disabled by adding #define NoExternalFunctionsto define.h and recompiling. The ability to call an Icon program from C normally is dis-abled when Icon is compiled. It can be enabled by adding #define IconCallingto define.h and recompiling. Since the ability to call an Iconprogram from C increases the overhead of calling C functions fromIcon (to support possible recursion), the ability to call an Iconprogram from C should not be enabled unless it is needed. To add external functions to Icon, it is only necessary towrite the appropriate code, place it in a file named extcall.c toreplace the distributed stub, and to link Icon with its objectmodule in place of the one for the stub. To call Icon from a C program, it is necessary to provide theC program and use its object module in place of the one foristart.c, which is used by default (see the second example inAppendix B). It is necessary to link the entire Icon run-timesystem with the calling program. The resulting executable file isquite large.5.__Bugs There presently is no mechanism for resuming a procedure thatsuspends as the result of icon_call(). A procedure called by icon_call() suspends by calling the Iconinterpreter. There is no mechanism for unwinding the system stackin such a situation. - 4 -6.__Acknowledgements The facilities described here were based on ones written byBill Griswold, using earlier work of Andy Heron. The implementa-tion for Version 8 of Icon was done by Sandra Miller and theauthor. Some of the material in this report was adapted fromimplementation notes provided by Bill Griswold.References1. R. E. Griswold, Version 8 of Icon, The Univ. of Arizona Tech. Rep. 90-1, 1990.2. R. E. Griswold and M. T. Griswold, The Implementation of the Icon Programming Language, Princeton University Press, 1986.3. R. E. Griswold, Supplementary Information for the Implementation of Version 8 of Icon, The Univ. of Arizona Icon Project Document IPD112, 1990. - 5 - Appendix A - Examples of External FunctionsExample_1:_Functions_Designated_by_Numbers /* * Example of calling C functions by integer codes. Here it's * one of three UNIX functions: * * 1: getpid (get process identification) * 2: getppid (get parent process identification) * 3: getpgrp (get process group) */ #include "../h/config.h" #include "../h/rt.h" #include "rproto.h" struct descrip retval; /* for returned value */ dptr extcall(dargv, argc, ip) dptr dargv; int argc; int *ip; { int retcode; int getpid(), getppid(), getpgrp(); *ip = -1; /* anticipate error-free execution */ if (cvint(dargv) == CvtFail) { /* 1st argument must be a string */ *ip = 101; /* "integer expected" error number */ return dargv; /* return offending value */ } - 6 - switch ((int)IntVal(*dargv)) { case 1: /* getpid */ retcode = getpid(); break; case 2: /* getppid */ retcode = getppid(); break; case 3: /* getpgrp */ if (argc < 2) { *ip = 205; /* no error number fits, really */ return NULL; /* no offending value */ } dargv++; /* get to next value */ if (cvint(dargv) == CvtFail) { /* 2nd argument must be integer */ *ip = 101; /* "integer expected" error number */ return dargv; } retcode = getpgrp(IntVal(*dargv)); break; default: *ip = 216; /* external function not found */ return NULL; } MakeInt(retcode,&retval); /* make an Icon integer for result */ return &retval; }Functions_Designated_by_Name /* * Example of calling C functions by their names. Here it's just * chdir (change directory) or getwd (get path of current working directory). */ #include "../h/config.h" #include "../h/rt.h" #include "rproto.h" struct descrip retval; /* for returned value */ - 7 - dptr extcall(dargv, argc, ip) dptr dargv; int argc; int *ip; { int len, retcode; char sbuf1[MaxCvtLen]; /* for conversion on non-strings */ char sbuf2[MaxCvtLen]; /* for C-style string */ int chdir(), getwd(); *ip = -1; /* anticipate error-free execution */ if (cvstr(dargv, sbuf1) == CvtFail) { /* 1st argument must be a string */ *ip = 103; /* "string expected" error number */ return dargv; /* return offending value */ } if (strncmp("chdir", StrLoc(*dargv), StrLen(*dargv)) == 0) { if (argc < 2) { /* must be a 2nd argument */ *ip = 103; /* no error number fits, really */ return NULL; /* no offedning value */ } dargv++; /* get to next argument */ if (cvstr(dargv, sbuf1) == CvtFail) { /* 2nd argument must be a string */ *ip = 103; /* "string expected" error number */ return dargv; /* return offending value */ } qtos(dargv,sbuf2); /* get C-style string in sbuf2 */ retcode = chdir(sbuf2); /* try to change directory */ if (retcode == -1) /* see if chdir failed */ return (dptr)NULL; /* signal failure */ return &zerodesc; /* not a very useful result */ } else if (strncmp("getwd", StrLoc(*dargv), StrLen(*dargv)) == 0) { dargv++; /* get to next argument */ retcode = getwd(sbuf2); /* get current working directory */ if (retcode == 0) /* see if getwd failed */ return NULL; /* signal failure */ len = strlen(sbuf2); /* length of resulting string */ if (strreq(len) == Error) { /* need to allocate a copy of result */ *ip = 0; /* zero since code is set elsewhere */ return (dptr)NULL; /* no offending value */ } StrLoc(retval) = alcstr(sbuf2,len); /* allocate and copy the string */ StrLen(retval) = len; return &retval; /* return a pointer to the qualifier */ } - 8 - else { *ip = 216; /* name is not one of those supported here */ return dargv; /* return pointer to offending value */ } } - 9 - Appendix B - Examples of Calling IconExample_1:_Calling_Icon_Procedures_from_the_Command_Line /* * Demonstration program to call an Icon procedure with arguments. This * program is used as * * iconval iprog proc arg1 arg2 ... * * where iprog is the name of the Icon icode file, proc is the name of * a procedure in it, and arg1, arg2, ... are arguments passed t
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:docs Folder:C Inter
+++++ Continued from previous card +++++
o proc. * It prints out the result if proc succeeds or notes if the procedure fails. * It prints a diagnostic message if proc is not a procedure in iprog. */ #include "../h/config.h" #include "../h/rt.h" #include "rproto extern int call_error; novalue main(argc,argv) int argc; char *argv[]; { int clargc; char **clargv; dptr retval, iargv; int i; char sbuf[MaxCvtLen]; /* * Read in the icode file argv[1] and initialize the Icon system. * This must be done for any C program calling Icon. */ icon_init(argv[1]); - 10 - /* * Skip the names of the executable and the file it processes. It * is only necessary to get the the procedure name and its arguments from * the command line. */ clargv = argv + 2; clargc = argc - 3; fprintf(stderr,"program=%s0,*clargv); fflush(stderr); /* * Malloc space for the list of descriptors and create Icon qualifiers * for each argument. */ iargv = (dptr)malloc(clargc * sizeof(struct descrip)); for (i = 0; i < clargc; i++) { StrLoc(iargv[i]) = clargv[i + 1]; StrLen(iargv[i]) = strlen(clargv[i + 1]); } retval = icon_call(*clargv, clargc, iargv); if (call_error) { fprintf(stderr,"procedure not found0); fflush(stderr); c_exit(ErrorExit); } if (retval == NULL) fprintf(stdout,"evaluation failed0); else { /* Check type of result returned. Don't attempt to print anything * but strings and integers here. */ if (Qual(*retval)) { qtos(retval,sbuf); fprintf(stdout," } else if (Type(*retval) == T_Integer) fprintf(stdout,"%ld0,IntVal(*retval)); else fprintf(stdout,"type=%d0,Type(*retval)); fflush(stdout); } c_exit(NormalExit); }Example_2:_Main_Program_for_Calling_Icon /* * Main program if Icon is called as a subprogram. */ - 11 - #include "../h/config.h" #include "../h/rt.h" #include "rproto.h" #ifdef IconCalling novalue main(argc,argv) int argc; char *argv[]; { int clargc; char **clargv; int i; struct descrip darg; /* * Set up standard Icon interface. This is only necessary so that * Icon can behave normally as if it were the main program. * It is not necessary if Icon is called by a C program for another * purpose. */ #if VMS redirect(&argc, argv, 0); #endif /* VMS */ icon_setup(argc, argv, &i); while (i--) { /* skip option arguments */ argc--; argv++; } if (!argc) error("no icode file specified"); /* * Read in the icode file argv[1] and initialize the Icon system. * This must for any C program calling Icon. */ icon_init(argv[1]); - 12 - /* * Skip the names of the executable and the file it processes. This * is necessary only to get the right arguments from the command line * to call Icon as if it were the main program and hence provide * the correct values in the list that is the argument of Icon's main * procedure. This is not necessary if Icon is called from C for * another purpose. */ clargv = argv + 2; clargc = argc - 2; /* * Set up a temporary stack and build the necessary list * to call main. */ sp = stack + Wsizeof(struct b_coexpr); PushNull; argp = (dptr)(sp - 1); for (i = 0; i < clargc; i++) { PushAVal(strlen(clargv[i])); PushVal(clargv[i]); } Ollist(clargc, argp); /* * Now that the list is computed, copy its descriptor off the * stack (which is about to be destroyed), reset the argument * pointer, and make the call to the Icon main procedure. */ darg = *argp; argp = 0; icon_call("main", 1, &darg); /* return signal and value ignored */ c_exit(NormalExit); } #else /* IconCalling */ static char x; /* avoid empty module */ #endif /* IconCalling */ - 13 - :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:docs Folder:DocInfo
MPW ICON DOCUMENTATION FILES ============================Several of the files on the distribution disk contain Icon documentationand background information. Some are text files and can be viewed andprinted by the MPW Shell. The fonts in MacWrite documents are optimizedfor printing on the LaserWriter.To print them on the ImageWriter, they will have the best quality if thefonts Times 12 and 10, Helvetica 12, and Courier 10 are installed (ordouble those sizes for “best” quality printing). Much of the style ofthe documents is expressed through their fonts, so it is best not totamper with them unless absolutely necessary. :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:docs Folder:Memory Monitoring
The Icon Memory Monitoring System Gregg M. Townsend Department of Computer Science, The University of ArizonaIntroduction The Icon memory monitoring system (``MemMon'') provides toolsfor displaying Icon's allocated data regions [1]. It consists ofinstrumentation that produces allocation history files (AppendixC) and visualization programs that convert allocation historyfiles to displays that show the sizes, types, and locations ofstrings as they are allocated. The garbage collection process isshown in detail. There are several visualization programs; most of them arespecific to the University of Arizona environment. Appendix Adescribes mmps, a program for producing displays that can beprinted on any PostScript printer. An allocation history file is produced by setting the environ-ment variable MEMMON to the name of the desired file. No changein the Icon program is necessary and the production of an alloca-tion history file does not change program behavior (except forincreasing run time somewhat). On Unix systems, if the value ofthe MEMMON environment variable begins with `|', the rest of thevalue is interpreted as a shell command into which the history ispiped.The_Display Icon has two primary allocated data regions: a string regionand a block region. On implementations that support regionexpansion [2], there is also a static region. The display showsthe regions as if they were contiguous, which they are on imple-mentations that support region expansion. The static region, ifit exists, comes first, followed by the string and block regions.The choice of regions that are displayed can be specified. Bydefault, the static region is not displayed, but the string andblock regions are. Color distinguishes the various uses of memory, and by infer-ence the region boundaries. A legend at the top of the screengives the meaning of each color. Default colors can be changedby providing an alternate specification file. Colors and boundaries are set at allocation time; subsequentchanges are not reflected until garbage collection occurs. Forexample, a string constructed in pieces may not show as a con-catenated whole. The line above the color legend gives the program status atIPD113a - 1 - March 6, 1990the left, the name of the allocation history file in the center,and storage information at the right, such as 60480 + 25600 + 51200 (0+0+1+0)The first three numbers give the current sizes (in bytes) of thestatic, string, and block regions respectively. The orderingreflects that of the display. The first three numbers inparentheses count the garbage collections caused by exhaustion ofthe regions, with the fourth number counting garbage collectionsinitiated by calls to collect(0).Garbage_Collection The garbage collection process is shown in detail by producingsnapshots at critical points. The first comes at the beginningof garbage collection, and indicates the reason the garbage col-lection is required. The next snapshot follows the marking phase. Active data isdark gray; the remaining blocks are garbage to be discarded. The next snapshot shows the marked (active) data in color,before compaction, with the garbage painted black. This is theinverse of the previous display. The last snapshot shows the state of memory at the end of gar-bage collection, after compacting the active data. All garbageis gone, and the string region shows a single unbroken string.At this point the image may be rescaled to handle region expan-sion. Alien blocks (such as I/O buffers) in the static region arenot subject to marking or garbage collection and instead remainon constant display throughout. Obsolete co-expression blocksare freed during the marking phase, but they are displayed in amanner similar to other blocks so that their disappearance can benoted.The_Programmer's_Interface Three built-in Icon functions write to the allocation historyto control a subsequent MemMon run. mmpause(s) generates a snapshot similar to those during gar-bage collection; the name comes from its effect on interactivevisualization programs, which pause at this point. s, if sup-plied, is displayed to identify the pause. The default for s is"programmed pause". mmshow(x,s) redraws x if x is in the managed memory region.This can be used to identify one or more particular data objectson the display. s determines the color of x:IPD113a - 2 - March 6, 1990 "w" white "g" gray "b" black "h" highlight: blinking white and black "r" redraw in normal color (the default)The altered display persists until the next garbage collection.If x is outside the managed memory region, no action is taken. mmout(s) writes s (without further interpretation) as aseparate line in the history file. This can be used to insertcomments (beginning with #). All three functions return the null value.Accessing_the_Monitoring_System The mmps program is built in the v8/src/memmon subdirectory ofthe Icon distribution. Instructions for running mmps appear inAppendix B. That subdirectory also includes some sample color specifica-tion files as well as code for building interactive visualizationprograms. Further information about this appears in [3].References1. R. E. Griswold and M. T. Griswold, The Implementation of the Icon Programming Language, Princeton University Press, 1986.2. R. E. Griswold, Supplementary Information for the Implementation of Version 7.9 of Icon, The Univ. of Arizona Icon Project Document IPD51d, 1989.3. G. M. Townsend, Notes on MemMon Internals, The Univ. of Arizona Icon Project Document IPD97a, 1989.4. Encapsulated PostScript File Format, Version 1.2, Adobe Systems Incorporated, 1987.IPD113a - 3 - March 6, 1990 Appendix A: Running mmps mmps generates Encapsulated Postscript [4] displays of Iconmemory. One or more images are produced under control of commandoptions. Output files are Encapsulated PostScript documentssuitable either for direct printing or for incorporation intoother documents. The output includes full color information,though most PostScript devices print only the black-and-whiteequivalent. The default image is 468 x 624 points, or 6.5" x 8.7",centered on a standard page. One line represents 1872 bytes ofmemory. Smaller or larger images can be specified; larger onesare reduced to fit within the above bounds.Command_format mmps [ options ] [ file ]Options -r regionsDisplay the indicated memory regions: f static (fixed) region s string region b block region The default is -r sb. -p when Produce a snapshot at the indicated points: f memory full (beginning of garbage collection) g showing garbage remaining after marking a showing unmarked, active blocks after marking c after compaction (end of garbage collection) p explicit mmpause() calls d (``done'') when the program terminates n never The default is -p fgacpd. -m Run through the marking phase even when not pausing to display the results. Normally, marking is bypassed if neither of -p ga is selected. -g n Skip to the end of the nth garbage collection before displaying anything. -q n Quit after completing the nth garbage collection. -Q n Quit after the nth snapshot. -b n Make each horizontal point represent n bytes of memory. The default is 4.IPD113a - 4 - March 6, 1990 -w n Set the display width to n points. The default is 468. -h n Set the display height to n points. The default is 624. -L n Make the legend and status lines n points high. -L 0 eliminates the header entirely. The default is 11. -M n Limit the memory region lines to a maximum of n points in height. The default is 20. -t titleSet the display title. The default is the allocation history file name. -c file Use an alternate color specification file (see Appendix B). -S n Set the PostScript screen frequency to n lines per inch.IPD113a - 5 - March 6, 1990 Appendix B: Color Specification Files A color specification file can be used to change some or allof the colors produced by mmps. The environment variable MMCOLORS can be used to name a filecontaining color specifications. mmps reads this file and usesit to override the normal defaults. Then, if a file is passed bythe -c option of mmps, it overrides both the built-in defaultsand anything from an MMCOLORS file. Lines in a color specification file contain two whitespace-separated fields, a label and a value, optionally followed bycomments. Blank lines are ignored, as are lines beginning with #. For example: # change the colors for sets set 657 light purple for set headers selem 637 medium putple for set elements The label field matches either one of the types shown in thelegend or one of these additional keywords: background background bsep block separator ssep string separator marked marked block unmarked unmarked block (when showing active data) status status message prompt prompt message title title field regions region sizes The value field is a set of three octal digits specifying acolor. The digits control the red, green, and blue colorcomponents in that order, with a range of 0 to 7 for each. Avalue of 0 is dark and a value of 7 is light. For example, 070is green (0% red + 100% green + 0% blue) and 405 is purple (4/7red + 5/7 blue). Unfortunately, the final colors are somewhatdevice-dependent because of different responses to the samespecification.IPD113a - 6 - March 6, 1990 Appendix C: Allocation History Files An allocation history file is composed of printable charactersforming a sequence of commands that trace interpreter actionsrelated to memory management. This section describes the overallstructure of an allocation history file, using terms and commandsthat are described later in detail. An allocation history file begins with a refresh sequence,which completely specifies the memory layout at a particularinstant. The initial refresh sequence gives a snapshot of memoryjust before the start of execution. Within a refresh sequence,item commands enumerate all the objects within the three regions,as if they are being placed, in order, into initially emptyregions. After the initial refresh sequence, the rest of the filecontains any number of the following components, in any order: item commands interaction commands garbage collection sequences Item commands, when outside other sequences, record newallocations of memory. Interaction commands are generated by programmed calls tommshow() and mmpause(). A garbage collection sequence begins with a marking sequence,in which item commands identify live objects. The markingsequence is followed by a new refresh sequence giving the memoryconfiguration after compaction. Then, a final marker signals theend of garbage collection. Comment and verification commands may appear at any point inthe file.Command_Format A command has several components: [addr+] [len] cmd [etc] addr is an optional address, given as a distance from the start of a region. If the address is omitted, the current end of the region is assumed. An address is always followed immediately by + . len is a length. If a length is needed by a command, but none is supplied, then the most recent length specified for that particular command is used.IPD113a - 7 - March 6, 1990 cmd is a single character identifying the command. etc is additional information needed by a few particular commands. Addresses and lengths are nonnegative decimal numbers. In thestring region, the unit of measurement is a character; in thestatic and block regions, it is specified in the refresh sequenceand usually is 4 bytes. Whitespace between commands is optional; whitespace within acommand is allowed only in etc data.Item_Commands Item commands identify individual allocated objects. Themeaning of an item command depends on its context. Within arefresh sequence, item commands enumerate the existingallocations. Within a marking sequence, item commands mark liveobjects. Otherwise, item commands announce new allocations. Except during marking, string and block region item commandsdo not include addresses. Addresses may be obtained by totalingthe allocations made since the beginning of the last refreshsequence. The item commands for the block region are: [addr+] [len] c cset [addr+] [len] e table element trapped variable [addr+] [len] E external block [addr+] [len] f file block [addr+] [len] L list header [addr+] [len] l list element [addr+] [len] R record [addr+] [len] r real number [addr+] [len] S set header [addr+] [len] s set element [addr+] [len] T table header [addr+] [len] t table element [addr+] [len] u substring trapped variable [addr+] [len] x co-expression refresh block The string item command is: [addr+] [len] " string The static region item commands always include an address.They are: addr + [len] X co-expression block addr + [len] A alien blockRefresh_Sequence_Commands [units] < static-region_string-region_block-region Begin a refresh sequence. Each region specification has the formIPD113a - 8 - March 6, 1990 base_: used_/ max where base is the beginning address of the region, used is the amount of memory used, and max is the amount of memory allocated to the region. For the static region, the used value is meaningless, and base and max are zero with fixed-region versions of Icon. All values in this command are given in bytes. The units parameter, if present, gives the size of a unit of measurement for other commands referencing the static and block regions. If the units parameter is absent, the unit of measurement is four bytes. > End a refresh sequenceVerification_Command = static-region_block-region_string-region Region specifications are the same as for the < command. This command provides no new information but confirms the accumulated memory usage after a series of allocations.Garbage_Collection_Commands n_{ Start a garbage collection and begin the marking phase n indicates the reason for the collection: 0 co
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:docs Folder:Memory
+++++ Continued from previous card +++++
llect(0) call 1 static region 2 string region 3 block region } End the marking phase ! End garbage collectionInteraction_Commands ; string Pause (produce a snapshot) and display string, which includes all characters up to a newline. This command is generated by a programmed mmpause(string) call. addr_+ len_$ c_t highlight a string addr_+ len_% c_t highlight a block addr_+ len_Y c_t highlight a static object Highlight commands are generated by programmed mmshow(x,s) calls. c is the first character of the argument string s, indicating the kind of highlighting desired. t identifies the type of the object being highlighted by giving the character used for an allocation command of that type.Comment_Command # comment All characters following the #, up to a newline, are ignored.Example Here is a small, contrived program that builds a list ofstrings, then inserts the strings in a set:IPD113a - 9 - March 6, 1990 procedure main () l := list () every put (l, string (-50 to 50)) s := set () every insert (s, !l) end Here is the corresponding history file: 4< 234076:60000/60000 294080:0/65024 359104:0/65024 2+2666F2670+2050A4722+2A4726+4A4732+8A4742+256A5000+10000X 0" > = 234076:60000/60000 294080:0/65024 359104:0/65024 5L23lLl3"""""""""l""""""""l""""""""31l""""""""""""43l""""2"""""""""1"" """61l"""""2""""""""""""""""""""""87l"""""""""""""""""""14S10h5sssssss sssssssssssssssssssssssssssssssssshsssssssssssssssssssssssssssssssssss sssss18hssssssssssssssssssss = 234076:60000/60000 294080:233/65024 359104:3524/65024IPD113a - 10 - March 6, 1990 :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:h Folder:config.h
/* * Icon configuration. *//* * System-specific definitions are in define.h */#include "::h:define.h"#include <stdio.h>/* * A number of symbols are defined here. Some are specific to individual * to operating systems. Examples are: * * MSDOS MS-DOS for PCs * UNIX any UNIX system * VMS VMS for the VAX * * These are defined to be 1 or 0 depending on which operating system * the installation is being done under. They are all defined and only * one is defined to be 1. (They are used in the form #if VAX || MSDOS.) * * There also are definitions of symbols for specific computers and * versions of operating systems. These include: * * SUN code specific to the Sun Workstation * MICROSOFT code specific to the Microsoft C compiler for MS-DOS * * Other definitions may occur for different configurations. These include: * * DeBug debugging code * MemMon memory monitoring output * * Other definitions perform configurations that are common to several * systems. An example is: * * Double align reals at double-word boundaries * *//* * The following definitions insure that all the symbols for operating * systems that are not relevant are defined to be 0 -- so that they * can be used in logical expressions in #if directives. */#ifndef PORT#define PORT 0#endif /* PORT */#ifndef AMIGA#define AMIGA 0#endif /* AMIGA */#ifndef ATARI_ST#define ATARI_ST 0#endif /* ATARI_ST */#ifndef HIGHC_386#define HIGHC_386 0#endif /* HIGHC_386 */#ifndef MACINTOSH#define MACINTOSH 0#endif /* MACINTOSH */#ifndef MSDOS#define MSDOS 0#endif /* MSDOS */#ifndef MVS#define MVS 0#endif /* MVS */#ifndef OS2#define OS2 0#endif /* OS2 */#ifndef UNIX#define UNIX 0#endif /* UNIX */#ifndef VM#define VM 0#endif /* VM */#ifndef VMS#define VMS 0#endif /* VMS *//* * The following definitions serve to cast common conditionals is * a positive way, while allowing defaults for the cases that * occur most frequently. That is, if co-expressions are not supported, * NoCoexpr is defined in define.h, but if they are supported, no * definition is needed in define.h; nonetheless subsequent conditionals * can be cast as #ifdef Coexpr. */#ifndef NoCoexpr#undef Coexpr#define Coexpr#endif /* NoCoexpr */#ifndef NoEnvVars#undef EnvVars#define EnvVars#endif /* NoEnvVars */#ifndef NoTraceBack#undef TraceBack#define TraceBack#endif /* NoTraceBack */#ifndef NoStrInvoke#undef StrInvoke#define StrInvoke#endif /* NoStrInvoke */#ifndef NoMathFncs#undef MathFncs#define MathFncs#endif /* NoMathFncs */#ifndef NoLargeInts#undef LargeInts#define LargeInts#endif /* NoLargeInts */#ifndef NoMemMon#ifdef EnvVars#undef MemMon#define MemMon#endif /* EnvVars */#endif /* NoMemMon */#ifndef NoExternalFunctions#undef ExternalFunctions#define ExternalFunctions#endif /* NoExternalFunctions *//* * EBCDIC == 0 corresponds to ASCII. EBCDIC == 1 corresponds to EBCDIC * collating sequence, while EBCDIC == 2 provides the ASCII collating * sequence for EBCDIC systems. */#ifndef EBCDIC#define EBCDIC 0#endif /* EBCDIC *//* * Other defaults. */#ifdef DeBug#undef DeBugTrans#undef DeBugLinker#undef DeBugIconx#define DeBugTrans#define DeBugLinker#define DeBugIconx#endif /* DeBug */#ifdef ExecImages#undef IconCalling#endif /* ExecImages */#ifndef AllocType#define AllocType unsigned int#endif /* AllocType */typedef AllocType msize;#ifndef ErrorExit#define ErrorExit 1#endif /* ErrorExit */#ifndef NormalExit#define NormalExit 0#endif /* NormalExit */#ifndef Hz#define Hz 60#endif /* Hz */#ifndef MaxHdr#define MaxHdr 4096#endif /* MaxHdr */#ifndef StackAlign#define StackAlign 2#endif /* StackAlign */#ifndef SysTime#define SysTime <time.h>#endif /* SysTime */#ifndef WordBits#define WordBits 32#endif /* WordBits */#ifndef IntBits#define IntBits WordBits#endif /* IntBits */#ifndef SourceSuffix#define SourceSuffix ".icn"#endif /* SourceSuffix */#ifndef IcodeSuffix#define IcodeSuffix ""#endif /* IcodeSuffix */#ifndef IcodeASuffix#define IcodeASuffix ""#endif /* IcodeASuffix */#ifndef U1Suffix#define U1Suffix ".u1"#endif /* U1Suffix */#ifndef U2Suffix#define U2Suffix ".u2"#endif /* U2Suffix */#ifndef USuffix#define USuffix ".u"#endif /* USuffix *//* * Representations of directories. LocalDir is the "current working directory". * SourceDir is where the source file is. */#define LocalDir ""#define SourceDir (char *)NULL#ifndef TargetDir#define TargetDir LocalDir#endif /* TargetDir */#ifndef Options#if UNIX#define Options "ce:mo:stuxLS:"#else /* UNIX */#define Options "ce:o:stuxLS:"#endif /* UNIX */#endif /* Options */#ifndef Usage#if UNIX#define Usage "[-cmstu] [-e efile] [-o ofile] [-Sxnnnn]"#else /* UNIX */#define Usage "[-cstu] [-e efile] [-o ofile] [-Sxnnnn]"#endif /* UNIX */#endif /* Usage */#ifndef Pipes#if UNIX || VMS#define Pipes#endif /* UNIX || VMS */#endif /* Pipes */#ifndef SystemFnc#if AMIGA || ATARI_ST || MSDOS || MVS || UNIX || VM || VMS#define SystemFnc#endif /* AMIGA || ATARI_ST || ... */#endif /* SystemFnc *//* * Default sizing and such. *//* * Set up typedefs and related definitions depending on whether or not * ints and pointers are the same size. */#if IntBits == 16typedef long int word;typedef unsigned long int uword;#else /* IntBits == 16 */typedef int word;typedef unsigned int uword;#endif /* IntBits == 16 */#define WordSize sizeof(word)#ifndef ByteBits#define ByteBits 8#endif /* ByteBits *//* * Define the size of the units in MemMon (allocation history) files. */#ifndef MMUnits#define MMUnits WordSize#endif /* MMUnits *//* * Change the name of gcvt() if we're supplying our own version, * to avoid complaints under VMS and others with shared libraries. */#ifdef IconGcvt#define gcvt icon_gcvt#endif /* IconGcvt *//* * The following definitions depend on whether or not the ANSI C standard * is supported. */#ifdef Standard#undef StandardC#undef StandardPP#define StandardC#define StandardPP#endif /* Standard */#ifdef StandardPP#define Cat(x,y) x##y#define Lit(x) #x#else /* StandardPP */#define Ident(x) x#define Cat(x,y) Ident(x)y#define Lit(x) "x"#endif /* StandardPP */#ifdef StandardC#undef Prototypes#define Prototypes#ifndef PointerDeftypedef void *pointer;#endif /* PointerDef */#undef VoidType#define VoidType#define Bell '\a'#else /* StandardC */#ifndef PointerDeftypedef char *pointer;#endif /* PointerDef */#if EBCDIC == 0#define Bell '\007'#else /* EBCDIC == 0 */#define Bell '\x2F'#endif /* EBCDIC == 0 */#endif /* StandardC *//* * Provide definition to use void if it's supported (mainly avoids error * messages with some C compilers. Note: typedef does not work, so care * is needed not to use compound declarations. */#ifdef VoidType#define novalue void#define noargs void#else /* VoidType */#define novalue int#define noargs#endif /* VoidType *//* * Customize output if not pre-defined. */#ifndef TraceOut#define TraceOut(s) fprintf(stderr,s)#endif /* TraceOut */#if EBCDIC == 0#define BackSlash "\\"#else /* EBCDIC == 0 */#define BackSlash "\xe0"#endif /* EBCDIC == 0 */#if UNIX#define WriteBinary "w"#define ReadBinary "r"#define WriteText "w"#define ReadText "r"#endif /* UNIX */#ifndef WriteBinary#define WriteBinarendif /* WriteBinary */#ifndef ReadBinary#define ReadBinary "rb"#endif /* ReadBinary */#ifndef WriteText#define WriteText "w"#endif /* WriteText */#ifndef ReadText#define ReadText "r"#endif /* ReadText *//* * Typedefs to make some things easier. */typedef int (*fptr)();typedef struct descrip *dptr;/* * "hidden" is used to declare static functions; "hidden" normally == "static", * except with compilers that can't handle "static" in prototypes. */#ifndef hidden#define hidden static#endif /* hidden *//* * The "Params" macro allows a single declaration to be used with both old- and * new-style compilers. */#ifdef Prototypes#define Params(a) a#else /* Prototypes */#define Params(a) ()#endif /* Prototypes *//* * cal_time holds a calendar time. */struct cal_time { int year; /* yyyy */ int month_no; /* month number: 1-12 */ char *month_nm; /* month name: "January", "February", ... */ int mday; /* day of the month */ char *wday; /* "Sunday", "Monday", ... */ int hour; /* hour by 24 hr clock */ int minute; int second; };/* * Function prototypes. */#include "::h:proto.h"/* * More definitions depending on whether or not ints and pointers * are the same size. These must follow the include of proto.h to * avoid redefinition problems with some compilers. */#if IntBits == 16#define sbrk lsbrk#define qsort llqsort#define strlen lstrlen#endif /* WordBits != IntBits *//* * The following code is operating-system dependent [@config.01]. * Any configuration stuff that has to be done at this point. */#if PORT /* Probably nothing is needed. */Deliberate Syntax Error#endif /* PORT */#if AMIGA || ATARI_ST || MACINTOSH || MSDOS || MVS || VM || VMS /* Nothing is needed */#endif /* AMIGA || MACINTOSH ...*/#if HIGHC_386/* * MetaWare's HighC 386 macro putc doesn't handle putc('\n') correctly - * sometimes a CR is not written out before the LF. So, redefine * macro putc to actually issue an fputc. */#undef putc#define putc(c,f) fputc(c,f)#endif /* HIGHC_386 */#if MACINTOSH#if LSC/* * LightSpeed C requires that #define tokens appear after prototypes */#define index strchr#define malloc mlalloc#define rindex strrchr#define unlink remove#endif /* LSC */#endif /* MACINTOSH */#if UNIX || (MACINTOSH && MPW)#undef WriteBinary#define WriteBinary "w"#undef ReadBinary#define ReadBinary "r"#ifndef NoHardWiredPaths#define HardWiredPaths#endif /* NoHardWiredPaths */#ifndef NoHeader#undef Header#define Header#endif /* NoHeader */#endif /* UNIX || (MACINTOSH && MPW) *//* * End of operating-system specific code. */#ifndef DiffPtrs#define DiffPtrs(p1,p2) (word)((p1)-(p2))#endif /* Diffptrs */#ifndef AllocReg#define AllocReg(n) malloc((msize)n)#endif /* AllocReg */ :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:h Folder:cpuconf.h
/* * Configuration parameters that depend on computer architecture. * Some depend on values defined in config.h, which is always * included before this file. */#ifndef CStateSize#define CStateSize 15 /* size of C state for co-expressions */#endif /* CStateSize *//* * The following definitions depend on the sizes of ints and pointers. *//* * Most of the present implementations use 32-bit "words". The section * for 64-bit words is tentative and untested. 16-bit words are no * longer supported. Note that WordBits is the number of bits in an Icon * integer, not necessarily the number of bits in an int (given by IntBits). * For example, in MS-DOS an Icon integer is a long, not an int. * * MaxStrLen must not be so large as to overlap flags. *//* * 64-bit words. NOTE: This section is under construction! */#if WordBits == 64#define MinLong ((long int)0x8000000000000000) /* smallest long integer */#define MaxLong ((long int)0x7fffffffffffffff) /* largest long integer */#define MaxDigits 40 /* maximum number of digits in images */#define MaxStrLen 017777777777L /* maximum string length */#define MaxNegInt "-9223372036854775808"#define F_Nqual 0x8000000000000000 /* set if NOT string qualifier */#define F_Var 0x4000000000000000 /* set if variable */#define F_Tvar 0x2000000000000000 /* set if trapped variable */#define F_Ptr 0x1000000000000000 /* set if value field is pointer */#endif /* WordBits == 64 *//* * 32-bit words. */#if WordBits == 32#define MaxLong ((long int)017777777777L) /* largest long integer */#define MinLong ((long int)020000000000L) /* smallest long integer */#define MaxDigits 20 /* maximum number of digits in images */#define MaxNegInt "-2147483648"#define MaxStrLen 0777777777 /* maximum string length */#define F_Nqual 0x80000000 /* set if NOT string qualifier */#define F_Var 0x40000000 /* set if variable */#define F_Tvar 0x20000000 /* set if trapped variable */#define F_Ptr 0x10000000 /* set if value field is pointer */#endif /* WordBits == 32 *//* Values that depend on the number of bits in an int (not necessarily * the same as the number of bits in a word). */#if IntBits == 64#define LogIntBits 6 /* log of IntBits */#define MaxUnsigned 01777777777777777777777L /* largest unsigned integer */#define MaxInt 0777777777777777777777L /* largest int *//* * Cset initialization macros. */#define fwd(w0, w1, w2, w3) \ ((w0)&0xffff : ((w1)&0xffff)<<16 : ((w2)&0xffff)<<32 : ((w3)&0xffff)<<48)#define cset_display(w0,w1,w2,w3,w4,w5,w6,w7,w8,w9,wa,wb,wc,wd,we,wf) \ {fwd(w0,w1,w2,w3),fwd(w4,w5,w6,w7),fwd(w8,w9,wa,wb),fwd(wc,wd,we,wf)}#endif /* IntBits == 64 */#if IntBits == 32#define LogIntBits 5 /* log of IntBits */#define MaxUnsigned 037777777777 /* largest unsigned integer */#define MaxInt 07777777777 /* largest int *//* * Cset initialization macros. */#define twd(w0,w1) ((w0)&0xffff | (w1)<<16)#define cset_display(w0,w1,w2,w3,w4,w5,w6,w7,w8,w9,wa,wb,wc,wd,we,wf) \ {twd(w0,w1),twd(w2,w3),twd(w4,w5),twd(w6,w7), \ twd(w8,w9),twd(wa,wb),twd(wc,wd),twd(we,wf)}#endif /* IntBits == 32 */#if IntBits == 16#define LogIntBits 4 /* log of IntBits */#define MaxUnsigned ((unsigned int)0177777) /* largest unsigned integer */#define MaxInt 077777 /* largest int *//* * Cset initialization macro. */#define cset_display(w0,w1,w2,w3,w4,w5,w6,w7,w8,w9,wa,wb,wc,wd,we,wf) \ {w0,w1,w2,w3,w4,w5,w6,w7,w8,w9,wa,wb,wc,wd,we,wf}#endif /* IntBits == 16 */#ifndef LogHuge#define LogHuge 309 /* maximum base-10 exp+1 of real */#endif /* LogHuge */#ifndef Big#define Big 9007199254740992. /* larger than 2^53 lose precision */#endif /* Big */#ifndef Precision#define Precision 10 /* digits in string from real */#endif /* Precision *//* * Parameters that configure tables and sets: * * HSlots Initial number of hash buckets; must be a power of 2. * LogHSlots Log to the base 2 of HSlots. * * HSegs Maximum number of hash bin segments; the maximum number of * hash bins is HSlots * 2 ^ (HSegs - 1). * * If Hsegs is increased above 12, the arrays log2[] and segsize[] * in iconx will need modification. * * MaxHLoad Maximum loading factor; more hash bins are allocated when * the average bin exceeds this many entries. * * MinHLoad Minimum loading factor; if a newly created table (e.g. via * copy()) is more lightly loaded than this, bins are combined. * * Because splitting doubles the number of hash bins, and combining halves it, * MaxHLoad should be at least twice MinHLoad. */#ifndef HSlots#if IntBits == 16#define HSlots 4#define LogHSlots 2#else#define HSlots 8#define LogHSlots 3#endif /* IntBits */#endif /* HSlots */#if ((1 << LogHSlots) != HSlots)Deliberate Syntax Error -- HSlots and LogHSlots are inconsistent#endif /* HSlots / LogHSlots consistency */#ifndef HSegs#if IntBits == 16#define HSegs 6#else#define HSegs 10#endif /* IntBits */#endif /* HSegs */#ifndef MinHLoad#define MinHLoad 1#endif /* MinHLoad */#ifndef MaxHLoad#define MaxHLoad 5#endif /* MaxHLoad *//* * The number of bits in each base-B digit; the type DIGIT (unsigned int) * in rt.h must be large enough to hold this many bits. * It must be at least 2 and at most WordBits / 2. */#define NB (WordBits / 2) :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:h Folder:define.h
/* * Standard Icon definitions for Macintosh Programmer's Workshop * (MPW) Icon. */#define Big 18446744073709551616.#define HostStr "Macintosh MPW"#define LogHuge 4933#define MaxHdr 512#define Precision 20#define SysTime "time.h"#define double extended#define index strche rindex strrchr#define VoidType#define Standard#define MACINTOSH 1#define MPW 1#define LSC 0#define memcopy(to,from,len) memcpy(to,from,len)#define memfill(to,char,len) memset(to,char,len) :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:h Folder:fdefs.h
/* * Definitions of functions. *//* * If this is a personalized interpreter, include definitions from the * pi directory. */#ifdef PersInterp#include "::pi:fdefs.h"#endif /* PersInterp *//* * These are the functions in the standard repertoire. */FncDef(abs,1)FncDef(any,4)FncDef(args,1)FncDef(bal,6)FncDef(center,3)FncDef(char,1)FncDef(close,1)FncDef(collect,2)FncDef(copy,1)FncDef(cset,1)FncDef(delete,2)FncDefV(detab)FncDef(display,2)FncDefV(entab)FncDef(errorclear,0)FncDef(exit,1)FncDef(find,4)FncDef(get,2)FncDef(getenv,1)FncDef(iand,2)FncDef(icom,1)FncDef(image,1)FncDef(insert,3)FncDef(integer,1)FncDef(ior,2)FncDef(ishift,2)FncDef(ixor,2)FncDef(key,2)FncDef(left,3)FncDef(list,2)FncDef(many,4)FncDef(map,3)FncDef(match,4)FncDef(member,1)FncDef(move,1)FncDef(name,1)FncDef(numeric,1)FncDef(open,2)FncDef(ord,1)FncDef(pop,1)FncDef(pos,1)FncDef(proc,2)FncDef(pull,1)FncDef(push,2)FncDef(put,1)FncDef(read,2)FncDef(reads,2)FncDef(real,1)FncDef(remove,2)FncDef(rename,1)FncDef(repl,2)FncDef(reverse,1)FncDef(right,3)FncDefV(runerr)FncDef(seek,2)FncDef(seq,2)FncDef(set,1)FncDef(sort,2)FncDefV(stop)FncDef(string,1)FncDef(tab,1)FncDef(table,1)FncDef(trim,2)FncDef(type,1)FncDef(upto,4)FncDef(variable,1)FncDef(where,1)FncDefV(write)FncDefV(writes)/* * System function. */#ifdef SystemFncFncDef(system,1)#endif /* SystemFnc *//* * Executable images. */#ifdef ExecImagesFncDef(save,1)#endif /* ExecImages *//* * External functions. */#ifdef ExternalFunctionsFncDefV(callout)#endif /* ExternalFunctions *//* * Math functions. */#ifdef MathFncsFncDef(acos,1)FncDef(asin,1)FncDef(atan,2)FncDef(cos,1)FncDef(dtor,1)FncDef(exp,2)FncDef(log,1)FncDef(rtod,1)FncDef(sin,1)FncDef(sqrt,1)FncDef(tan,1)#endif /* MathFncs */#ifdef KeyboardFncsFncDef(getch,0)FncDef(getche,0)FncDef(kbhit,0)#endif /* KeyboardFncs *//* * Functions for MS-DOS. */#ifdef DosFncsFncDef(Int86,1)FncDef(Peek,1)FncDef(Poke,1)FncDef(GetSpace,1)FncDef(FreeSpace,1)FncDef(InPort,1)FncDef(OutPort,1)#endif /* DosFncs *//* * Memory monitoring functions. */#ifdef MemMonFncDef(mmout,1)FncDef(mmpause,1)FncDef(mmshow,2)#endif /* MemMon */#ifdef EvalTraceFncDef(I__,2)FncDef(T__,3)FncDef(X__,2)#endif /* EvalTrace */ :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:h Folder:header.h
/* * Interpreter code file header - this is written at the start of * an icode file after the start-up program. */struct header { word hsize; /* size of interpreter code */ word trace; /* initial value of &trace */ word records; /* location of record blocks */ word ftab; /* location of record/field table */ word fnames; /* location of names of fields */ word globals; /* location of global variables */ word gnames; /* location of names of globals */ word statics; /* location of static variables */ word strcons; /* location of identifier table */ word filenms; /* location of ipc/file name table */ word linenums; /* location of ipc/line number table */ word config[16]; /* icode version */ }; :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:h Folder:keyword.h
/* * Memory sizing. */#ifdef FixedRegions#undef IconAlloc#ifndef AlcMax#define AlcMax 25#endif /* AlcMax */#endif /* FixedRegions *//* * Maximum sized block that can be allocated (via malloc() or such). */#ifndef MaxBlock#define MaxBlock MaxUnsigned#endif /* MaxBlock *//* * What follows is default memory sizing. Implementations with special * requirements may specify these values in define.h. */#ifndef MaxStatSize#ifdef Coexpr#define MaxStatSize 20480 /* size of the static region in bytes*/#else /* Coexpr */#define MaxStatSize 1024 /* size of the static region in bytes */#endif /* Coexpr */#endif /* MaxStatSize */#ifndef MaxStrSpace#define MaxStrSpace 65000 /* size of the string space in bytes */#endif /* MaxStrSpace */#ifndef MaxAbrSize#define MaxAbrSize 65000 /* size of the block region in bytes */#endif /* MaxAbrSize */#ifndef MStackSize#define MStackSize 10000 /* size of the main stack in words */#endif /* MStackSize */#ifndef StackSize#define StackSize 2000 /* words in co-expression stack */#endif /* StackSize */#ifndef QualLstSize#define QualLstSize 5000 /* size of qualifier pointer region */#endif /* QualLstSize */#ifndef ActStkBlkEnts#ifdef Coexpr#define ActStkBlkEnts 100 /* number of entries in an astkblk */#else /* Coexpr */#define ActStkBlkEnts 1 /* number of entries in an astkblk */#endif /* Coexpr */#endif /* ActStkBlkEnts *//* * Minimum regions sizes (presently not used). */#ifndef MinStatSize#ifdef Coexpr#define MinStatSize 10240 /* size of the static region in bytes*/#else /* Coexpr */#define MinStatSize 1024 /* size of static region in bytes */#endif /* Coexpr */#endif /* MinStatSize */#ifndef MinStrSpace#define MinStrSpace 5000 /* size of the string space in bytes */#endif /* MinStrSpace */#ifndef MinAbrSize#define MinAbrSize 5000 /* size of the block region in bytes */#endif /* MinAbrSize */#ifndef MinMStackSize#define MinMStackSize 2000 /* size of the main stack in words */#endif /* MinMStackSize */#ifndef MinStackSize#define MinStackSize 1000 /* words in co-expression stack */#endif /* MinStackSize */#ifndef MinQualLstSize#define MinQualLstSize 500 /* size of qualifier pointer region */#endif /* MinQualLstSize */#ifndef GranSize#define GranSize 64 /* storage allocation granule size */#endif /* GranSize */#ifndef Sqlinc#define Sqlinc 128*sizeof(dptr *) /* qualifier pointer list increment */#endif /* Sqlinc */ :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:h Folder:odefs.h
/* * Definitions and declarations used throughout the run-time system. * These are also used by the linker in constructing data for use by * the run-time system. */#ifdef StandardC#include <time.h>#endif /* StandardC */#include "::h:cpuconf.h"#include "::h:memsize.h"/* * Constants that are not likely to vary between implementations. */#define BitOffMask (IntBits-1)#define CsetSize (256/IntBits) /* number of ints to hold 256 cset * bits. Use (256/IntBits)+1 if * 256 % IntBits != 0 */#define MinListSlots 8 /* number of elements in an expansion * list element block */#define MaxCvtLen 257 /* largest string in conversions; the extra * one is for a terminating null */#define MaxReadStr 512 /* largest string to read() in one piece */#define MaxIn 32767 /* largest number of bytes to read() at once */#define RandA 1103515245 /* random seed multiplier */#define RandC 453816694 /* random seed additive constant */#define RanScale 4.65661286e-10 /* random scale factor = 1/(2^31-1)) *//* * File status flags in status field of file blocks. */#define Fs_Read 01 /* read access */#define Fs_Write 02 /* write access */#define Fs_Create 04 /* file created on open */#define Fs_Append 010 /* append mode */#define Fs_Pipe 020 /* reading/writing on a pipe *//* * Definitions for interpreter actions. */#define A_Failure 1 /* routine failed */#define A_Suspension 2 /* routine suspended */#define A_Return 3 /* routine returned */#define A_Pret_uw 4 /* interp unwind for Op_Pret */#define A_Unmark_uw 5 /* interp unwind for Op_Unmark */#define A_Resumption 6 /* resume generator */#define A_Pfail_uw 7 /* interp unwind for Op_Pfail */#define A_Lsusp_uw 8 /* interp unwind for Op_Lsusp */#define A_Eret_uw 9 /* interp unwind for Op_Eret */#define A_Coact 10 /* co-expression activated */#define A_Coret 11 /* co-expression returned */#define A_Cofail 12 /* co-expression failed *//* * Codes returned by invoke to indicate action. */#define I_Builtin 201 /* A built-in routine is to be invoked */#define I_Fail 202 /* goal-directed evaluation failed */#define I_Continue 203 /* Continue execution in the interp loop */#define I_Vararg 204 /* A function with a variable number of args *//* * Codes returned by runtime support routines. * Note, some conversion routines also return type codes. Other routines may * return positive values other than return codes. sort() places restrictions * on Less, Equal, and Greater. */#define Less -1#define Equal 0#define Greater 1#define CvtFail -2#define Cvt -3#define NoCvt -4#define Failure -5#define Defaulted -6#define Success -7#define Error -8/* * Generator types. */#define G_Csusp 1#define G_Esusp 2#define G_Psusp 3/* * Type codes (descriptors and blocks). */#define T_Null 0 /* null value */#define T_Integer 1 /* integer */#ifdef LargeInts#define T_Bignum 2 /* long integer */#endif /* LargeInts */#define T_Real 3 /* real number */#define T_Cset 4 /* cset */#define T_File 5 /* file */#define T_Proc 6 /* procedure */#define T_List 7 /* list header */#define T_Table 8 /* table header */#define T_Record 9 /* record */#define T_Telem 10 /* table element */#define T_Lelem 11 /* list element */#define T_Tvsubs 12 /* substring trapped variable */#define T_Tvkywd 13 /* keyword trapped variable */#define T_Tvtbl 14 /* table element trapped variable */#define T_Set 15 /* set header */#define T_Selem 16 /* set element */#define T_Refresh 17 /* refresh block */#define T_Coexpr 18 /* co-expression */#define T_External 19 /* external block */#define T_Slots 20 /* set/table hash slots */#define MaxType 20 /* maximum type number *//* * Descriptor types and flags. */#define D_Null (word)(T_Null | F_Nqual)#define D_Integer (word)(T_Integer | F_Nqual)#ifdef LargeInts#define D_Bignum (word)(T_Bignum | F_Ptr | F_Nqual)#endif /* LargeInts */#define D_Real (word)(T_Real | F_Ptr | F_Nqual)#define D_Cset (word)(T_Cset | F_Ptr | F_Nqual)#define D_File (word)(T_File | F_Ptr | F_Nqual)#define D_Proc (word)(T_Proc | F_Ptr | F_Nqual)#define D_List (word)(T_List | F_Ptr | F_Nqual)#define D_Table (word)(T_Table | F_Ptr | F_Nqual)#define D_Telem (word)(T_Telem | F_Ptr | F_Nqual)#define D_Tvsubs (word)(T_Tvsubs | D_Tvar)#define D_Tvkywd (word)(T_Tvkywd | D_Tvar)#define D_Tvtbl (word)(T_Tvtbl | D_Tvar)#define D_Record (word)(T_Record | F_Ptr | F_Nqual)#define D_Set (word)(T_Set | F_Ptr | F_Nqual)#define D_Refresh (word)(T_Refresh | F_Ptr | F_Nqual)#define D_Coexpr (word)(T_Coexpr | F_Ptr | F_Nqual)#define D_External (word)(T_External | F_Ptr | F_Nqual)#define D_Slots (word)(T_Slots | F_Ptr | F_Nqual)#define D_Var (word)(F_Var | F_Nqual | F_Ptr)#define D_Tvar (word)(D_Var | F_Tvar)#define TypeMask 63 /* type mask */#define OffsetMask (~(D_Tvar)) /* offset mask for variables */ /* * Run-time data structures. *//* * Icode consists of operators and arguments. Operators are small integers, * while arguments may be pointers. To conserve space in icode files on * computers with 16-bit ints, icode is written by the linker as a mixture * of ints and words (longs). When an icode file is read in and processed * by the interpreter, it looks like a C array of mixed ints and words. * Accessing this "nonstandard" structure is handled by a union of int and * word pointers and incrementing is done by incrementing the appropriate * member of the union (see the interpreter). This is a rather dubious * method and certainly not portable. A better way might be to address * icode with a char *, but the incrementing code might be inefficient * (at a place that experiences a lot of execution activity). * * For the moment, the dubious coding is isolated under control of the * size of integers. */#if IntBits == 16typedef union { int *op; word *opnd; } inst;#else /* IntBits == 16 */typedef union { word *op; word *opnd; } inst;#endif /* IntBits == 16 *//* * Descriptor */struct descrip { /* descriptor */ word dword; /* type field */ union { word integr; /* integer value */ char *sptr; /* pointer to character string */ union block *bptr; /* pointer to a block */ dptr descptr; /* pointer to a descriptor */ } vword; };struct sdescrip { word length; /* length of string */ char *string; /* pointer to string */ };/* * Run-time error numbers and text. */struct errtab { int err_no; /* error number */ char *errmsg; /* error message */ };/* * Frame markers */struct ef_marker { /* expression frame marker */ inst ef_failure; /* failure ipc */ struct ef_marker *ef_efp; /* efp */ struct gf_marker *ef_gfp; /* gfp */ word ef_ilevel; /* ilevel */ };struct pf_marker { /* procedure frame marker */ word pf_nargs; /* number of arguments */ struct pf_marker *pf_pfp; /* saved pfp */ struct ef_marker *pf_efp; /* saved efp */ struct gf_marker *pf_gfp; /* saved gfp */ dptr pf_argp; /* saved argp */ inst pf_ipc; /* saved ipc */ word pf_ilevel; /* saved ilevel */ dptr pf_scan; /* saved scanning environment */ struct descrip pf_locals[1]; /* descriptors for locals */ };struct gf_marker { /* generator frame marker */ word gf_gentype; /* type */ struct ef_marker *gf_efp; /* efp */ struct gf_marker *gf_gfp; /* gfp */ inst gf_ipc; /* ipc */ struct pf_marker *gf_pfp; /* pfp */ dptr gf_argp; /* argp */ };/* * Generator frame marker dummy -- used only for sizing "small" * generator frames where procedure infomation need not be saved. * The first five members here *must* be identical to those for * gf_marker. */struct gf_smallmarker { /* generator frame marker */ word gf_gentype; /* type */ struct ef_marker *gf_efp; /* efp */ struct gf_marker *gf_gfp; /* gfp */ inst gf_ipc; /* ipc */ };#ifdef LargeIntstypedef unsigned int DIGIT;struct b_bignum { /* large integer block */ word title; /* T_Bignum */ word blksize; /* ze */ word msd, lsd; /* most and least significant digits */ int sign; /* sign; 0 positive, 1 negative */ DIGIT digits[1]; /* digits */ };#endif /* LargeInts */struct b_real { /* real block */ word title; /* T_Real */ double realval; /* value */ };struct b_cset { /* cset block */ word title; /* T_Cset */ word size; /* size of cset */ int bits[CsetSize]; /* array of bits */ };struct b_file { /* file block */ word title; /* T_File */ FILE *fd; /* Unix file descriptor */ word status; /* file status */ struct descrip fname; /* file name (string qualifier) */ };struct b_proc { /* procedure block */ word title; /* T_Proc */ word blksize; /* size of block */ union { /* entry points for */ int (*ccode)(); /* C routines */ uword ioff; /* and icode as offset */ pointer icode; /* and icode as absolute pointer */ } entryp; word nparam; /* number of parameters */ word ndynam; /* number of dynamic locals */ word nstatic; /* number of static locals */ word fstatic; /* index (in global table) of first static */ struct descrip pname; /* procedure name (string qualifier) */ struct descrip lnames[1]; /* list of local names (qualifiers) */ };/* * b_iproc blocks are used to statically initialize information about * functions. They are identical to b_proc blocks except for * the pname field which is a sdecrip (simple/string descriptor) instead * of a descrip. This is done because unions cannot be initialized. */ struct b_iproc { /* procedure block */ word ip_title; /* T_Proc */ word ip_blksize; /* size of block */ int (*ip_entryp)(); /* entry point (code) */ word ip_nparam; /* number of parameters */ word ip_ndynam; /* number of dynamic locals */ word ip_nstatic; /* number of static locals */ word ip_fstatic; /* index (in global table) of first static */ struct sdescrip ip_pname; /* procedure name (string qualifier) */ struct descrip ip_lnames[1]; /* list of local names (qualifiers) */ };struct b_list { /* list-header block */ word title; /* T_List */ word size; /* current list size */ word id; /* identification number */ union block *listhead; /* pointer to first list-element block */ union block *listtail; /* pointer to last list-element block */ };struct b_lelem { /* list-element block */ word title; /* T_Lelem */ word blksize; /* size of block */ union block *listprev; /* previous list-element block */ union block *listnext; /* next list-element block */ word nslots; /* total number of slots */ word first; /* index of first used slot */ word nused; /* number of used slots */ struct descrip lslots[1]; /* array of slots */ };struct b_slots { /* set/table hash slots */ word title; /* T_Slots */ word blksize; /* size of block */ union block *hslots[HSlots]; /* array of slots (HSlots * 2^n entries) */ };struct b_table { /* table-header block */ word title; /* T_Table */ word size; /* current table size */ word id; /* identification number */ word mask; /* mask to get slot num, equals n slots - 1 */ struct b_slots *hdir[HSegs]; /* directory of hash slot segments */ struct descrip defvalue; /* default table element value */ };struct b_telem { /* table-element block */ word title; /* T_Telem */ union block *clink; /* hash chain link */ uword hashnum; /* for ordering chain */ struct descrip tref; /* entry value */ struct descrip tval; /* assigned value */ };/* * A set header must be a proper prefix of a table header, * and a set element must be a proper prefix of a table element. */struct b_set { /* set-header block */ word title; /* T_Set */ word size; /* size of the set */ word id; /* identification number */ word mask; /* mask to get slot num, equals n slots - 1 */ struct b_slots *hdir[HSegs]; /* directory of hash slot segments */ };struct b_selem { /* set-element block */ word title; /* T_Selem */ union block *clink; /* hash chain link */ uword hashnum; /* hash number */ struct descrip setmem; /* the element */ };struct b_record { /* record block */ word title; /* T_Record */ word blksize; /* size of block */ word id; /* identification number */ union block *recdesc; /* pointer to record constructor */ struct descrip fields[1]; /* fields */ };/* * Alternate uses for procedure block fields, applied to records. */#define nfields nparam /* number of fields */#define recnum nstatic /* record number */#define recid fstatic /* record serial number */#define recname pname /* record name */struct b_tvkywd { /* keyword trapped variable block */ word title; /* T_Tvkywd */ int (*putval)(); /* assignment function for keyword */ struct descrip kyval; /* keyword value */ struct descrip kyname; /* keyword name */ };struct b_tvsubs { /* substring trapped variable block */ word title; /* T_Tvsubs */ word sslen; /* length of substring */ word sspos; /* position of substring */ struct descrip ssvar; /* variable that substring is from */ };struct b_tvtbl { /* table element trapped variable block */ word title; /* T_Tvtbl */ union block *clink; /* pointer to table header block */ uword hashnum; /* hash number */ struct descrip tref; /* entry value */ struct descrip tval; /* reserved for assigned value */ };struct b_coexpr { /* co-expression stack block */ word title; /* T_Coexpr */ word size; /* number of results produced */ word id; /* identification number */ struct b_coexpr *nextstk; /* pointer to next allocated stack */ struct pf_marker *es_pfp; /* current pfp */ struct ef_marker *es_efp; /* efp */ struct gf_marker *es_gfp; /* gfp */ dptr es_argp; /* argp */ inst es_ipc; /* ipc */ word es_ilevel; /* interpreter level */ word *es_sp; /* sp */ dptr tvalloc; /* where to place transmitted value */ struct descrip freshblk; /* refresh block pointer */ struct astkblk *es_actstk; /* pointer to activation stack structure */ word cstate[CStateSize]; /* C state information */ };struct astkblk { /* co-expression activator-stack block */ int nactivators; /* number of valid activator entries in * this block */ struct astkblk *astk_nxt; /* next activator block */ struct actrec { /* activator record */ word acount; /* number of calls by this activator */ struct b_coexpr *activator; /* the activator itself */ } arec[ActStkBlkEnts]; };struct b_refresh { /* co-expression block */ word title; /* T_Refresh */ word blksize; /* size of block */ word *ep; /* entry point */ word numlocals; /* number of locals */ struct pf_marker pfmkr; /* marker for enclosing procedure */ struct descrip elems[1]; /* arguments and locals, including Arg0 */ };struct b_external { /* external block */ word title; /* T_External */ word blksize; /* size of block */ word descoff; /* offset to first descriptor */ word exdata[1]; /* words of external data */ };union block { /* general block */#ifdef LargeInts struct b_bignum bignumblk;#endif /* LargeInt
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:h Folder:rt.h
+++++ Continued from previous card +++++
s */ struct b_real realblk; struct b_cset cset; struct b_file file; struct b_proc proc; struct b_list list; struct b_lelem lelem; struct b_table table; struct b_telem telem; struct b_set set; struct b_selem selem; struct b_record record; struct b_tvkywd tvkywd; struct b_tvsubs tvsubs; struct b_tvtbl tvtbl; struct b_refresh refresh; struct b_coexpr coexpr; struct b_external externl; struct b_slots slots; };/* * Declarations for entries in tables ang icode location with * source program location. */struct ipc_fname { word ipc; /* offset of instruction into code region */ word fname; /* offset of file name into string region */ };struct ipc_line { word ipc; /* offset of instruction into code region */ int line; /* line number */ }; /* * External declarations. */extern char *code; /* start of icode */extern word stksize; /* size of co-expression stacks in words */extern word *stackend; /* end of evaluation stack */extern struct b_coexpr *stklist;/* base of co-expression stack list */extern word mstksize; /* size of main stack in words */extern char *statbase; /* start of static space */extern char *statend; /* end of static space */extern char *statfree; /* static space free list header */extern word statsize; /* size of static space */extern word statincr; /* size of increment for static space */extern word ssize; /* size of string space (bytes) */extern char *strbase; /* start of string space */extern char *strend; /* end of string space */extern char *strfree; /* string space free pointer */extern word abrsize; /* size of allocated block region (words) */extern char *blkbase; /* base of allocated block region */extern char *blkend; /* maximum address in allocated block region */extern char *blkfree; /* first free location in allocated block region */extern int bsizes[]; /* sizes of blocks */extern int firstd[]; /* offset (words) of first descrip. */extern char *blkname[]; /* print names for block types. */extern uword segsize[]; /* size of hash bucket segment */extern struct b_tvkywd tvky_err; /* trapped variable for &error */extern struct b_tvkywd tvky_pos; /* trapped variable for &pos */extern struct b_tvkywd tvky_ran; /* trapped variable for &random */extern struct b_tvkywd tvky_sub; /* trapped variable for &subject */extern struct b_tvkywd tvky_trc; /* trapped variable for &trace */#define k_error tvky_err.kyval.vword.integr /* value of &error */#define k_pos tvky_pos.kyval.vword.integr /* value of &pos */#define k_random tvky_ran.kyval.vword.integr /* value of &random */#define k_subject tvky_sub.kyval /* value of &subject */#define k_trace tvky_trc.kyval.vword.integr /* value of &trace */extern struct b_cset k_ascii; /* value of &ascii */extern struct b_cset k_cset; /* value of &cset */extern struct b_cset k_digits; /* value of &lcase */extern struct b_file k_errout; /* value of &errout */extern struct b_file k_input; /* value of &input */extern struct b_cset k_lcase; /* value of &lcase */extern struct b_cset k_letters; /* value of &letters */extern int k_level; /* value of &level */extern char *k_errortext; /* value of &errortext */extern int k_errornumber; /* value of &errornumber */extern struct descrip k_errorvalue; /* value of &errorvalue */extern struct descrip k_main; /* value of &main */extern struct descrip k_current; /* ¤t */extern struct b_file k_output; /* value of &output */extern struct b_cset k_ucase; /* value of &ucase */#ifdef SASCextern clock_t starttime; /* start time in milliseconds */#else /* SASC */extern long starttime; /* start time in milliseconds */#endif /* SASC */extern struct descrip nulldesc; /* null value */extern struct descrip zerodesc; /* zero */extern struct descrip onedesc; /* one */extern struct descrip emptystr; /* empty string */extern struct descrip blank; /* blank */extern struct descrip letr; /* letter "r" */extern struct descrip maps2; /* second argument to map() */extern struct descrip maps3; /* third argument to map() */extern struct descrip input; /* &input */extern struct descrip errout; /* &errout */extern struct descrip lcase; /* lowercase string */extern struct descrip ucase; /* uppercase string */extern int ntended; /* number of active tended descriptors */extern struct descrip tended[]; /* tended descriptors */extern word *sp; /* interpreter stack pointer */extern word *stack; /* interpreter stack base */extern struct pf_marker *pfp; /* procedure frame pointer */extern struct ef_marker *efp; /* expression frame pointer */extern struct gf_marker *gfp; /* generator frame pointer */extern inst ipc; /* interpreter program counter */extern dptr argp; /* argument pointer */extern int ilevel; /* interpreter level */#ifdef ExecImagesextern int dumped; /* the interpreter has been dumped */#endif /* ExecImages */#if EBCDIC == 2extern char ToEBCDIC[], FromEBCDIC[]; /* ASCII<->EBCDIC maps */#define ToAscii(e) (FromEBCDIC[e])#define FromAscii(e) (ToEBCDIC[e])#else /* EBCDIC == 2 */#define ToAscii(e) (e)#define FromAscii(e) (e)#endif /* EBCDIC == 2 */ /* * Evaluation stack overflow margin */#define PerilDelta 100/* * Macro definitions related to descriptors. *//* * The following code is operating-system dependent [@rt.01]. Define * PushAval for computers that store longs and pointers differently. */#if PORT#define PushAVal(x) PushVal(x)Deliberate Syntax Error#endif /* PORT */#if AMIGA || ATARI_ST || HIGHC_386 || MACINTOSH || MVS || UNIX || VM || VMS#define PushAVal(x) PushVal(x)#endif /* AMIGA || ATARI_ST || HIGHC_386 ... */#if MSDOS || OS2static union { pointer stkadr; word stkint; } stkword;#define PushAVal(x) {sp++; \ stkword.stkadr = (char *)(x); \ *sp = stkword.stkint;}#endif /* MSDOS || OS2 *//* * End of operating-system specific code. *//* * Pointer to block. */#define BlkLoc(d) ((d).vword.bptr)/* * Check for null-valued descriptor. */#define ChkNull(d) ((d).dword==D_Null)/* * Dereference descriptor. */#define DeRef(d) (Var(d) ? deref(&d) : Success)/* * Check for equivalent descriptors. */#define EqlDesc(d1,d2) ((d1).dword == (d2).dword && BlkLoc(d1) == BlkLoc(d2))/* * Integer value. */#define IntVal(d) ((d).vword.integr)/* * Offset from top of block to value of variable. */#define Offset(d) ((d).dword & OffsetMask)/* * Check for pointer. */#define Pointer(d) ((d).dword & F_Ptr)/* * Check for qualifier. */#define Qual(d) (!((d).dword & F_Nqual))/* * Length of string. */#define StrLen(q) ((q).dword)/* * Location of first character of string. */#define StrLoc(q) ((q).vword.sptr)/* * Check for trapped variable. */#define Tvar(d) ((d).dword & F_Tvar)/* * Location of trapped-variable block. */#define TvarLoc(d) ((d).vword.bptr)/* * Type of descriptor. */#define Type(d) (int)((d).dword & TypeMask)/* * Check for variable. */#define Var(d) ((d).dword & F_Var)/* * Location of the value of a variable. */#define VarLoc(d) ((d).vword.descptr)/* * Important note: The code that follows is not strictly legal C. * It tests to see if pointer p2 is between p1 and p3. This may * involve the comparison of pointers in different arrays, which * is not well-defined. The casts of these pointers to unsigned "words" * (longs or ints, depending) works with all C compilers and architectures * on which Icon has been implemented. However, it is possible it will * not work on some system. If it doesn't, there may be a "false * positive" test, which is likely to cause a memory violation or a * loop. It is not practical to implement Icon on a system on which this * happens. */#define InRange(p1,p2,p3) ((uword)(p2) >= (uword)(p1) && (uword)(p2) < (uword)(p3))/* * Macros for pushing values on the interpreter stack. *//* * Push descriptor. */#define PushDesc(d) {*++sp = ((d).dword); sp++;*sp =((d).vword.integr);}/* * Push null-valued descriptor. */#define PushNull {*++sp = D_Null; sp++; *sp = 0;}/* * Push word. */#define PushVal(v) {*++sp = (word)(v);}/* * Macros related to function and operator definition. *//* * Procedure block for a function. */#define FncBlock(f,nargs,deref) \ struct b_iproc Cat(B,f) = {\ T_Proc,\ Vsizeof(struct b_proc),\ Cat(X,f),\ nargs,\ -1,\ deref, 0,\ {sizeof(Lit(f))-1,Lit(f)}};/* * Function declaration for variable number of arguments. */#define FncDcl(nm,n) FncBlock(nm,n,0) Cat(X,nm)(cargp) register dptr cargp;/* * Function declaration for variable number of arguments. */#define FncDclV(nm) FncBlock(nm,-1,0) Cat(X,nm)(nargs,cargp) register dptr cargp;/* * Function declaration without dereferenced arguments. */#define FncNDcl(nm,n) FncBlock(nm,n,-1) Cat(X,nm)(cargp) register dptr cargp;/* * Function declaration for variable number of arguments. */#define FncNDclV(nm) FncBlock(nm,-1,-1) Cat(X,nm)(nargs,cargp) register dptr cargp;/* * Declaration for library routine. */#define LibDcl(nm,n,pn) OpBlock(nm,n,pn,0) Cat(O,nm)(nargs,cargp) \ register dptr cargp;/* * Procedure block for an operator. */#define OpBlock(f,nargs,sname,realargs)\ struct b_iproc Cat(B,f) = {\ T_Proc,\ Vsizeof(struct b_proc),\ Cat(O,f),\ nargs,\ -1,\ realargs,\ 0,\ {sizeof(sname)-1,sname}};/* * Operator declaration. */#define OpDcl(nm,n,pn) OpBlock(nm,n,pn,0) Cat(O,nm)(cargp) register dptr cargp;/* * Agent routine declaration. */#define AgtDcl(nm) Cat(A,nm)(cargp) register dptr cargp;#ifdef StrInvoke/* * Structure for mapping string names of procedures to block addresses. */struct pstrnm { char *pstrep; struct b_proc *pblock; };#endif /* StrInvoke *//* * Macros to access Icon arguments in C functions. *//* * n-th argument. */#define Arg(n) (cargp[n])/* * Type field of n-th argument. */#define ArgType(n) (cargp[n].dword)/* * Value field of n-th argument. */#define ArgVal(n) (cargp[n].vword.integr)/* * Specific arguments. */#define Arg0 (cargp[0])#define Arg1 (cargp[1])#define Arg2 (cargp[2])#define Arg3 (cargp[3])#define Arg4 (cargp[4])#define Arg5 (cargp[5])#define Arg6 (cargp[6])/* * Code expansions for exits from C code for top-level routines. */#define Fail return A_Failure#define Return return A_Return#define Suspend { \ int rc; \ if ((rc = interp(G_Csusp,cargp)) != A_Resumption) \ return rc;} #define Forward(agent) return Cat(A,agent)(cargp)/* * Miscellaneous macro definitions. *//* * Error exit from non top-level routines. */#define RetError(n,v) {\ k_errornumber = n;\ k_errortext = "";\ k_errorvalue = v;\ return Error;}/* * Get floating-point number from real block. */#ifdef Double#define GetReal(dp,res) { \ word *rp, *rq; \ rp = (word *) &(res); \ rq = (word *) &(BlkLoc(*dp)->realblk.realval); \ *rp++ = *rq++; \ *rp = *rq;} #else /* Double */#define GetReal(dp,res) res = BlkLoc(*dp)->realblk.realval#endif /* Double *//* * Absolute value of x (word). */#define Abs(x) (((x) < 0) ? (-(x)) : (x))/* * Maximum of x and y. */#define Max(x,y) ((x)>(y)?(x):(y))#ifdef SASC /* remove comments for Relase 4.50 *//* #undef Max *//* #define Max(x,y) __builtin_max(x,y) */#endif /* SASC *//* * Minimum of x and y. */#define Min(x,y) ((x)<(y)?(x):(y))#ifdef SASC /* remove comments for Relase 4.50 *//* #undef Min *//* #define Min(x,y) __builtin_min(x,y) */#endif /* SASC *//* * Some C compilers take '\n' and '\r' to be the same, so the * following definitions are used. */#if EBCDIC/* * Note that, in EBCDIC, "line feed" and "new line" are distinct * characters. Icon's use of "line feed" is really "new line" in * C terms. */#define LineFeed '\n' /* if really "line feed", that's 37 */#define CarriageReturn '\r'#else /* EBCDIC */#define LineFeed 10#define CarriageReturn 13#endif /* EBCDIC *//* * Construct an integer descriptor. */#define MakeInt(i,dp) { \ (dp)->dword = D_Integer; \ IntVal(*dp) = (word)(i);}/* * Check whether a set or table needs resizing. */#define SP(p) ((struct b_set *)p)#define TooCrowded(p) \ ((SP(p)->size > MaxHLoad*(SP(p)->mask+1)) && (SP(p)->hdir[HSegs-1] == NULL))#define TooSparse(p) \ ((SP(p)->hdir[1] != NULL) && (SP(p)->size < MinHLoad*(SP(p)->mask+1)))/* * RunErr encapsulates a call to the function runerr, followed * by Fail. The idea is to avoid the problem of calling * runerr directly and forgetting that it may actually return. */#define RunErr(n,dp) {\ runerr((int)n,dp);\ Fail;\ }/* * Vsizeof is for use with variable-sized (i.e., indefinite) * structures containing an array of descriptors declared of size 1 * to avoid compiler warnings associated with 0-sized arrays. */#define Vsizeof(s) (sizeof(s) - sizeof(struct descrip))/* * Offset in word of cset bit. */#define CsetOff(b) ((b) & BitOffMask) /* * Address of word of cset bit. */#define CsetPtr(b,c) ((c) + (((b)&0377) >> LogIntBits)) /* * Set bit b in cset c. */#define Setb(b,c) (*CsetPtr(b,c) |= (01 << CsetOff(b))) /* * Test bit b in cset c. */#define Testb(b,c) ((*CsetPtr(b,c) >> CsetOff(b)) & 01) /* * Handy sizeof macros: * * Wsizeof(x) -- Size of x in words. * Vwsizeof(x) -- Size of x in words, minus the size of a descriptor. Used * when structures have a potentially null list of descriptors * at their end. */#define Wsizeof(x) ((sizeof(x) + sizeof(word) - 1) / sizeof(word))#define Vwsizeof(x) ((sizeof(x) - sizeof(struct descrip) +sizeof(word) - 1)\ / sizeof(word))/* * Definitions and declarations used for storage management. */#define F_Mark 0100000 /* bit for marking blocks */#define Static 1 /* collection is for static region */#define Strings 2 /* collection is for strings */#define Blocks 3 /* collection is for blocks *//* * External definitions. */extern char *currend; /* current end of memory region */extern uword blkneed; /* stated need for block space */extern uword strneed; /* stated need for string space */extern uword statneed;extern dptr globals; /* start of global variables */extern dptr eglobals; /* end of global variables */extern dptr gnames; /* start of global variable names */extern dptr egnames; /* end of global variable names */extern dptr statics; /* start of static variables */extern dptr estatics; /* end of static variables */extern dptr *quallist; /* start of qualifier list */extern word qualsize;/* * Get type of block pointed at by x. */#define BlkType(x) (*(word *)x)/* * BlkSize(x) takes the block pointed to by x and if the size of * the block as indicated by bsizes[] is nonzero it returns the * indicated size; otherwise it returns the second word in the * block contains the size. */#define BlkSize(x) (bsizes[*(word *)x & ~F_Mark] ? \ bsizes[*(word *)x & ~F_Mark] : *((word *)x + 1))/* * If memory monitoring is not enabled, redefine function calls * to do nothing. */#ifndef MemMon#define MMAlc(n,t)#define MMBGC(r)#define MMEGC()#define MMMark(b,t)#define MMShow(d,s)#define MMStat(a,l,c)#define MMStr(n)#define MMSMark(a,n)#endif /* MemMon */#ifndef FixedRegions/* * Information used with Icon's allocation routines with expandable-regions * memory management. */typedef int ALIGN; /* pick most stringent type for alignment */union bhead { /*
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:h Folder:rt.h
+++++ Continued from previous card +++++
header of free block */ struct { union bhead *ptr; /* pointer to next free block */ uword bsize; /* free block size */ } s; ALIGN x; /* force block alignment */ };typedef union bhead HEADER;#define NALLOC 64 /* units to request at one time */#define FREEMAGIC 0x807F /* magic flag for free blocks (MemMon only) */#endif /* FixedRegions */ :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:h Folder:time.h
typedef long time_t;typedef long clock_t;struct tm { short tm_sec; short tm_min; short tm_hour; short tm_mday; short tm_mon; short tm_year; short tm_wday; short tm_yday; short tm_isdst; /* Not available on Macintosh */ short tm_hsec; /* Not available on Macintosh */};struct tm *gmtime(), *localtime();char *asctime(), *ctime();time_t time(); :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:h Folder:version.h
/* * Value identification information. */#define Version "Icon Version 8.0. February 14, 1990"/* * Version numbers to be sure ucode is compatible with the linker * and icode is compatible with the run-time system. */#define UVersion "U8.0.002"#ifdef IconCalling#define IVersion "I8.0.001+C"#else /* IconCalling */#define IVersion "I8.0.001"#endif /* IconCalling */ :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:icont Folder:err.c
/* * err.c -- routines for producing error messages. */#include "::h:config.h"#include "tproto.h"#include "token.h"#include "tlex.h"#include "trans.h"#include "tree.h"/* * Prototype. */char *mapterm Params((int typ,struct node *val));extern int tfatals;static struct errmsg { int e_state; /* parser state number */ char *e_mesg; /* message text */ } errtab[] = { /* * Initialization of table that maps error states to messages. */ 1, "end of file expected", 2, "global, record, or procedure declaration expected", 11, "missing semicolon", 13, "link list expected", 15, "global, record, or procedure declaration expected", 16, "missing record name", 19, "invalid global declaration", 24, "missing procedure name", 26, "missing field list in record declaration", 28, "missing end", 29, "missing semicolon or operator", 44, "invalid argument for unary operator", 45, "invalid argument for unary operator", 46, "invalid argument for unary operator", 47, "invalid argument for unary operator", 48, "invalid argument for unary operator", 49, "invalid argument for unary operator", 50, "invalid argument for unary operator", 51, "invalid argument for unary operator", 52, "invalid argument for unary operator", 53, "invalid argument for unary operator", 54, "invalid argument for unary operator", 55, "invalid argument for unary operator", 56, "invalid argument for unary operator", 57, "invalid argument for unary operator", 58, "invalid argument for unary operator", 59, "invalid argument for unary operator", 60, "invalid argument for unary operator", 61, "invalid argument for unary operator", 62, "invalid argument for unary operator", 63, "invalid argument for unary operator", 64, "invalid argument for unary operator", 65, "invalid argument for unary operator", 66, "invalid argument for unary operator", 67, "invalid argument for unary operator", 77, "invalid create expression", 84, "invalid keyword construction", 92, "invalid if control expression", 93, "invalid case control expression", 94, "invalid while control expression", 95, "invalid until control expression", 96, "invalid every control expression", 97, "invalid repeat expression", 100, "missing link file name", 101, "missing parameter list in procedure declaration", 104, "invalid local declaration", 105, "invalid initial expression", 110, "invalid argument", 111, "invalid argument", 112, "invalid argument in assignment", 113, "invalid argument in assignment", 114, "invalid argument in assignment", 115, "invalid argument in assignment", 116, "invalid argument in augmented assignment", 117, "invalid argument in augmented assignment", 118, "invalid argument in augmented assignment", 119, "invalid argument in augmented assignment", 120, "invalid argument in augmented assignment", 121, "invalid argument in augmented assignment", 122, "invalid argument in augmented assignment", 123, "invalid argument in augmented assignment", 124, "invalid argument in augmented assignment", 125, "invalid argument in augmented assignment", 126, "invalid argument in augmented assignment", 127, "invalid argument in augmented assignment", 128, "invalid argument in augmented assignment", 129, "invalid argument in augmented assignment", 130, "invalid argument in augmented assignment", 131, "invalid argument in augmented assignment", 132, "invalid argument in augmented assignment", 133, "invalid argument in augmented assignment", 134, "invalid argument in augmented assignment", 135, "invalid argument in augmented assignment", 136, "invalid argument in augmented assignment", 137, "invalid argument in augmented assignment", 138, "invalid argument in augmented assignment", 139, "invalid argument in augmented assignment", 140, "invalid argument in augmented assignment", 141, "invalid argument in augmented assignment", 142, "invalid argument in augmented assignment", 143, "invalid argument in augmented assignment", 144, "invalid to clause", 145, "invalid argument in alternation", 146, "invalid argument", 147, "invalid argument", 148, "invalid argument", 149, "invalid argument", 150, "invalid argument", 151, "invalid argument", 152, "invalid argument", 153, "invalid argument", 154, "invalid argument", 155, "invalid argument", 156, "invalid argument", 157, "invalid argument", 158, "invalid argument", 159, "invalid argument", 160, "invalid argument", 161, "invalid argument", 162, "invalid argument", 163, "invalid argument", 164, "invalid argument", 165, "invalid argument", 166, "invalid argument", 167, "invalid argument", 168, "invalid argument", 169, "invalid argument", 170, "invalid argument", 171, "invalid argument", 172, "invalid argument", 173, "invalid argument", 177, "invalid field name", 204, "missing right parenthesis", 206, "missing right brace", 208, "missing right bracket", 214, "missing then", 215, "missing of", 220, "missing identifier", 223, "missing right parenthesis", 225, "missing end", 226, "invalid declaration", 227, "missing semicolon or operator", 293, "missing right bracket", 296, "missing right brace", 298, "missing right parenthesis", 305, "invalid do clause", 306, "invalid then clause", 307, "missing left brace", 308, "invalid do clause", 309, "invalid do clause", 310, "invalid do clause", 312, "invalid argument list", 318, "invalid by clause", 320, "invalid section", 331, "invalid case clause", 336, "missing right bracket", 338, "missing right bracket or ampersand", 340, "invalid else clause", 341, "missing right brace or semicolon", 343, "missing colon", 344, "missing colon or ampersand", 349, "invalid case clause", 350, "invalid default clause", 351, "invalid case clause", -1, "syntax error" }; /* * yyerror produces syntax error messages. tok is the offending token * (yychar), lval is yylval, and state is the parser's state. * * errtab is searched for the state, if it is found, the associated * message is produced; if the state isn't found, "syntax error" * is produced. */novalue yyerror(tok, lval, state)int tok, state;nodeptr lval; { register struct errmsg *p; if (tok_loc.n_file) fprintf(stderr, "File %s; ", tok_loc.n_file); if (tok == EOFX) /* special case end of file */ fprintf(stderr, "unexpected end of file\n"); else { fprintf(stderr, "Line %d # ", Line(lval)); if (Col(lval)) fprintf(stderr, "\"%s\": ", mapterm(tok,lval)); for (p = errtab; p->e_state != state && p->e_state >= 0; p++) ; fprintf(stderr, "%s\n", p->e_mesg); } tfatals++; nocode++; } /* * tfatal produces the translator error messages s1 and s2 (if nonnull). The * location of the error is found in tok_loc. */novalue tfatal(s1, s2)char *s1, *s2; { if (tok_loc.n_file) fprintf(stderr, "File %s; ", tok_loc.n_file); fprintf(stderr, "Line %d # ", tok_loc.n_line); if (s2) fprintf(stderr, "\"%s\": ", s2); fprintf(stderr, "%s\n", s1); tfatals++; nocode++; } /* * nfatal produces the error message s and associates it with source location * of node. */novalue nfatal(n, s)nodeptr n;char *s; { fprintf(stderr, "File %s; ", File(n)); fprintf(stderr, "Line %d # ", Line(n)); fprintf(stderr, "%s\n", s); tfatals++; nocode++; } /* * mapterm finds a printable string for the given token type * and value. */static char *mapterm(typ,val)int typ;nodeptr val; { register struct toktab *t; register int i; i = typ; if (i == IDENT || i == INTLIT || i == REALLIT || i == STRINGLIT || i == CSETLIT) return Str0(val); for (t = toktabype != i; t++) if (t->t_type == 0) return "???"; return (t->t_word); } :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:icont Folder:general.h
/* * general.h - general definitions used in both translation and linking. */#define MaxFileName 256struct fileparts { /* struct of file name parts */ char *dir; /* directory */ char *name; /* name */ char *ext; /* extension */#if MVS char *member;#endif /* MVS */ }; :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:icont Folder:globals.h
/* * Global variables. */#ifndef Global#define Global extern#define Init(v)#endif /* Global *//* * Table sizes and defaults come from sizes.h. */#define Size(cmd,vname,defalt) Global unsigned int vname Init(defalt);#define MinSize(x,y,z)#include "sizes.h"#undef Size#undef MinSize/* * Masks for accessing hash tables. */Global int cmask; /* mask for constant table hash */Global int fmask; /* mask for field table hash */Global int gmask; /* mask for global table hash */ Global int imask; /* mask for identifier table hash */Global int lmask; /* mask for local table hash *//* * Variables related to command processing. */Global char *progname Init("icont"); /* program name for diagnostics */#if ATARTI_STGlobal char *patharg Init(0); /* -p: path for finding iconx */#endif /* ATARI_ST */Global int silent Init(0); /* -s: suppress info messages? */Global int m4pre Init(0); /* -m: use m4 preprocessor? [UNIX] */Global int uwarn Init(0); /* -u: warn about undefined ids? */Global int trace Init(0); /* -t: initial &trace value */#ifdef DeBugLinkerGlobal int Dflag Init(0); /* -L: linker debug (write .ux file) */#endif /* DeBugLinker */ :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:icont Folder:hdr.h
/* * Iconx header for Macintosh MPW Icon */static char iconxhdr[] = "\"{icon}iconx\" \"{Command}\" {\"Parameters\"};Exit;"; :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:icont Folder:icont.r
/* Commando dialog definition for the Icon Programming Language translator and linker (icont).*/#include "Cmdo.r"#include "Types.r"resource 'cmdo' (128) { { /* array dialogs: 2 elements */ /* [1] */ 295, "Icont — Icon Programming Language Translator & Linker. " "Clicking on any control will display a help message in this box.", { /* array itemArray */ /* [1] */ NotDependent {}, MultiFiles { "Input File(s)…", "Choose the source (.icn) & icode (.u1) files you " "wish to include.", /*{30, 24, 54, 132},*/ {30, 76, 54, 184}, "Source & Ucode Files:", "", MultiInputFiles { { /* array MultiTypesArray: 1 elements */ /* [1] */ /*text*/ /* .u? files are not TEXT */ }, ".icn", "Files ending in .icn", /*"All text files"*/ "All files" } }, /* [2] */ Or { {1} }, Files { InputOrOutputFile, OptionalFile { {117, 261, 133, 429}, {133, 261, 152, 429}, "Icode File Name", "Root name of 1st file", "-o", " (root name)", "This is the name to give to the executable " "program (icode file). The default is the root " "portion of the first source or ucode file specified.", dim, "Default icode file", "Select existing icode file…", "Create new icode file…" }, Additional { "-o", "", "", "", { /* array TypesArray */ text } } }, /* [3] */ NotDependent { }, NestedDialog { 2, {166, 150, 182, 300}, "Table Size Options…", "Translator and linker table sizes may b" "e specified with this button." }, /* [4] */ NotDependent {}, Redirection { StandardInput, {30, 210} }, /* [5] */ NotDependent {}, Redirection { StandardOutput, {30, 338} }, /* [6] */ NotDependent {}, Redirection { DiagnosticOutput, {68, 274} }, /* [7] */ NotDependent {}, TextBox { gray, {20, 200, 112, 460}, "Input and Output Redirection" }, /* [8] */ NotDependent {}, CheckOption { NotSet, {68, 24, 84, 190}, "Translate only", "-c", "Translate source files to create ucode files only " "— do not link." }, /* [9] */ NotDependent {}, CheckOption { NotSet, {92, 24, 108, 190}, "Suppress messages", "-s", "Suppress output of non-error, informative messages." }, /* [10] */ NotDependent {}, CheckOption { NotSet, {116, 24, 132, 190}, "Trace", "-t", "Give keyword &trace an initial value of -1 when " "program is executed." }, /* [11] */ NotDependent {}, CheckOption { NotSet, {140, 24, 156, 240}, "Warn undeclared identifiers", "-u", "Issue warning messages for undeclared identifiers." }, NotDependent {}, PictOrIcon { Icon, 128, {24, 24, 56, 56}, }, NotDependent {}, Box { gray, {18, 18, 62, 62} } }, /* [2] */ 280, "Use this dialog to alter translator " "and linker table sizes.", { NotDependent {}, RegularEntry { "Constant table", {24, 112, 40, 248}, {24, 24, 40, 102}, "100", true, "-Sc", "Size of constant table." }, NotDependent {}, RegularEntry { "Field table", {48, 112, 64, 248}, {48, 24, 64, 102}, "100", true, "-Sf", "Size of field table." }, NotDependent {}, RegularEntry { "Global symbol table", {72, 112, 88, 248}, {72, 24, 88, 102}, "200", true, "-Sg", "Size of global symbol table." }, NotDependent {}, RegularEntry { "Identifier table", {96, 112, 112, 248}, {96, 24, 112, 102}, "500", true, "-Si", "Size of identifier table." }, NotDependent {}, RegularEntry { "Local symbol table", {120, 112, 136, 248}, {120, 24, 136, 102}, "100", true, "-Sl", "Size of local symbol table." }, NotDependent {}, RegularEntry { "Line number table", {144, 112, 160, 248}, {144, 24, 160, 102}, "1000", true, "-Sn", "Size of line number table." }, NotDependent {}, RegularEntry { "Record table", {24, 358, 40, 478}, {24, 270, 40, 348}, "100", true, "-Sr", "Size of record table." }, NotDependent {}, RegularEntry { "String space", {48, 358, 64, 478}, {48, 270, 64, 348}, "20000", true, "-Ss", "Size of string space." }, NotDependent {}, RegularEntry { "Tree space", {72, 358, 88, 478}, {72, 270, 88, 348}, "15000", true, "-St", "Size of tree space." }, NotDependent {}, RegularEntry { "Code buffer", {96, 358, 112, 478}, {96, 270, 112, 348}, "15000", true, "-SC", "Size of code buffer." }, NotDependent {}, RegularEntry { "File names", {120, 358, 136, 478}, {120, 270, 136, 348}, "10", true, "-SF", "Size of file name table." }, NotDependent {}, RegularEntry { "Labels", {144, 358, 160, 478}, {144, 270, 160, 348}, "500", true, "-SL", "Size of label table." } } }};/* This is the ICON resource that creates the icon for the icon logo for the Icon Programming Language.*/resource 'ICON' (128) { $"0003 0000 000C 0000 001C 0000 0038 0000" $"0033 8000 0006 C000 000C 6000 0006 0000" $"0033 1800 0079 3C00 00CC 6630 00CC 6638" $"0278 3C9C 0630 19CC 0C00 0362 88C0 0622" $"8D80 0060 6730 18C0 7278 3C80 38CC 6600" $"18CC 6600 0079 3C00 0031 9800 0000 C000" $"000C 6000 0006 C000 0003 9800 0000 3800" $"0000 7000 0000 6000 0001 80"}; :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:icont Folder:keyword.c
/* * lcode.c -- linker routines to parse .u1 files and produce icode. */#include <math.h>#include "::h:config.h"#include "tproto.h"#include "globals.h"#include "opcode.h"#include "link.h"#include "general.h"#include "::h:keyword.h"#include "::h:version.h"#include "::h:header.h"/* * Prototypes. */hidden novalue backpatch Params((int lab));hidden novalue clearlab Params((noargs));hidden novalue flushcode Params((noargs));hidden novalue intout Params((int oint));hidden novalue lemit Params((int op,char *name));hidden novalue lemitcon Params((int k));hidden novalue lemiteven Params((noargs));hidden novalue lemitin Params((int op,word offset,int n,char *name));hidden novalue lemitint Params((int op,long i,char *name));hidden novalue lemitl Params((int op,int lab,char *name));hidden novalue lemitn Params((int op,word n,char *name));hidden novalue lemitproc Params((char *name,int nargs,int ndyn,int nstat, int fstat));hidden novalue lemitr Params((int op,word loc,char *name));hidden novalue outblock Params((char *addr,int count));hidden novalue wordout Params((word oword));#ifdef DeBugLinkerhidden novalue dumpblock Params((char *addr,int count));#endif /* DeBugLinker */#if AMIGA#include <fcntl.h>#endif /* AMIGA */#ifndef MaxHeader#define MaxHeader MaxHdr#endif /* MaxHeader */word pc = 0; /* simulated program counter */#define outword(n) wordout((word)(n))#define outop(n) intout((int)(n))#define CodeCheck(n) if ((long)codep + n > (long)((long)codeb + maxcode))\ quit("out of code buffer space") /* * gencode - read .u1 file, resolve variable references, and generate icode. * Basic process is to read each line in the file and take some action * as dictated by the opcode. This action sometimes involves parsing * of arguments and usually culminates in the call of the appropriate * lemit* routine. */novalue gencode() { register int op, k, lab; int j, nargs, flags, implicit; char *id, *name, *procname; struct centry *cp; struct gentry *gp; struct fentry *fp; union xval gg; while ((op = getopc(&name)) != EOF) { switch (op) { /* Ternary operators. */ case Op_Toby: case Op_Sect: /* Binary operators. */ case Op_Asgn: case Op_Cat: case Op_Diff: case Op_Div: case Op_Eqv: case Op_Inter: case Op_Lconcat: case Op_Lexeq: case Op_Lexge: case Op_Lexgt: case Op_Lexle: case Op_Lexlt: case Op_Lexne: case Op_Minus: case Op_Mod: case Op_Mult: case Op_Neqv: case Op_Numeq: case Op_Numge: case Op_Numgt: case Op_Numle: case Op_Numlt: case Op_Numne: case Op_Plus: case Op_Power: case Op_Rasgn: case Op_Rswap: case Op_Subsc: case Op_Swap: case Op_Unions: /* Unary operators. */ case Op_Bang: case Op_Compl: case Op_Neg: case Op_Nonnull: case Op_Null: case Op_Number: case Op_Random: case Op_Refresh: case Op_Size: case Op_Tabmat: case Op_Value: /* Instructions. */ case Op_Bscan: case Op_Ccase: case Op_Coact: case Op_Cofail: case Op_Coret: case Op_Dup: case Op_Efail: case Op_Eret: case Op_Escan: case Op_Esusp: case Op_Limit: case Op_Lsusp: case Op_Pfail: case Op_Pnull: case Op_Pop: case Op_Pret: case Op_Psusp: case Op_Push1: case Op_Pushn1: case Op_Sdup: newline(); lemit(op, name); break; case Op_Chfail: case Op_Create: case Op_Goto: case Op_Init: lab = getlab(); newline(); lemitl(op, lab, name); break; case Op_Cset: case Op_Real: k = getdec(); newline(); lemitr(op, lctable[k].c_pc, name); break; case Op_Field: id = getid(); newline(); fp = flocate(id); if (fp == NULL) { lfatal(id, "invalid field name"); break; } lemitn(op, (word)(fp->f_fid-1), name); break; case Op_Int: { long i; k = getdec(); newline(); cp = &lctable[k]; /* * Check to see if a large integers has been converted to a string. * If so, generate the code for +s. */ if (cp->c_flag & F_StrLit) { id = cp->c_val.sval; lemit(Op_Pnull,"pnull"); lemitin(Op_Str, (word)(id-lsspace), cp->c_length, "str"); lemit(Op_Number,"number"); break; } i = (long)cp->c_val.ival; lemitint(op, i, name); break; } case Op_Invoke: k = getdec(); newline(); if (k == -1) lemit(Op_Apply,"apply"); else lemitn(op, (word)k, name); break; case Op_Keywd: k = getdec(); newline(); switch (k) { case K_FAIL: lemit(Op_Efail,"efail"); break; case K_NULL: lemit(Op_Pnull,"pnull"); break; default: lemitn(op, (word)k, name); } break; case Op_Llist: k = getdec(); newline(); lemitn(op, (word)k, name); break; case Op_Lab: lab = getlab(); newline();#ifdef DeBugLinker if (Dflag) fprintf(dbgfile, "L%d:\n", lab);#endif /* DeBugLinker */ backpatch(lab); break; case Op_Line: if (lnfree >= &lntable[nsize]) quit("out of line number table space"); lnfree->ipc = pc; lineno = getdec(); lnfree->line = lineno; lnfree++;#ifdef EvalTrace lemitn(op, (word)lineno, name);#endif /* EvalTrace */ newline();#ifdef LineCodes lemit(Op_Noop,"noop");#endif /* LineCodes */ break;#ifdef EvalTrace case Op_Colm: colmno = getdec(); lemitn(op, (word)colmno, name); break;#endif /* EvalTrace */ case Op_Mark: lab = getlab(); newline(); lemitl(op, lab, name); break; case Op_Mark0: lemit(op, name); break; case Op_Str: k = getdec(); newline(); cp = &lctable[k]; id = cp->c_val.sval; lemitin(op, (word)(id-lsspace), cp->c_length, name); break; case Op_Tally: k = getdec(); newline(); lemitn(op, (word)k, name); break; case Op_Unmark: lemit(Op_Unmark, name); break; case Op_Var: k = getdec(); newline(); flags = lltable[k].l_flag; if (flags & F_Global) lemitn(Op_Global, (word)(lltable[k].l_val.global-lgtable), "global"); else if (flags & F_Static) lemitn(Op_Static, (word)(lltable[k].l_val.staticid-1), "static"); else if (flags & F_Argument) lemitn(Op_Arg, (word)(lltable[k].l_val.offset-1), "arg"); else lemitn(Op_Local, (word)(lltable[k].l_val.offset-1), "local"); break; /* Declarations. */ case Op_Proc: procname = getid(); newline(); locinit(); clearlab(); lineno = 0; gp = glocate(procname); implicit = gp->g_flag & F_ImpError; nargs = gp->g_nargs; lemiteven(); break; case Op_Local: k = getdec(); flags = getoct(); id = getid(); putlocal(k, id, flags, implicit, procname); break; case Op_Con: k = getdec(); flags = getoct(); if (flags & F_IntLit) { { long m; char *s; j = getdec(); /* number of characters in integer */ m = getint(j,&s); /* convert if possible */ if (m < 0) { /* negative indicates integer too big */ gg.sval = s; /* convert to a string */ putconst(k, F_StrLit, j, pc, &gg); } else { /* integers is small enough */ gg.ival = m; putconst(k, flags, 0, pc, &gg); } } } else if (flags & F_RealLit) { gg.rval = getreal(); putconst(k, flags, 0, pc, &gg); } else if (flags & F_StrLit) { j = getdec(); gg.sval = getstrlit(j); putconst(k, flags, j, pc, &gg); } else if (flags & F_CsetLit) { j = getdec(); gg.sval = getstrlit(j); putconst(k, flags, j, pc, &gg); } else fprintf(stderr, "gencode: illegal constant\n"); newline(); lemitcon(k); break; case Op_Filen: if (fnmfree >= &fnmtbl[fnmsize]) quit("out of file name table space"); fnmfree->ipc = pc; fnmfree->fname = getrest() - lsspace;/* fnmfree->fname = getid() - lsspace; */ fnmfree++; newline(); break; case Op_Declend: newline(); gp->g_pc = pc; lemitproc(procname, nargs, dynoff, lstatics-static1, static1); break; case Op_End: newline(); flushcode(); break; default: fprintf(stderr, "gencode: illegal opcode(%d): %s\n", op, name); newline(); } } } /* * lemit - emit opcode. * lemitl - emit opcode with reference to program label. * for a description of the chaining and backpatching for labels. * lemitn - emit opcode with integer argument. * lemitr - emit opcode with pc-relative reference. * lemitin - emit opcode with reference to identifier table & integer argument. * lemitint - emit word opcode with integer argument. * lemiteven - emit null bytes to bring pc to word boundary. * lemitcon - emit constant table entry. * lemitproc - emit procedure block. * * The lemit* routines call out* routines to effect the "outputting" of icode. * Note that the majority of the code for the lemit* routines is for debugging * purposes. */static novalue lemit(op, name)int op;char *name; {#ifdef DeBugLinker if (Dflag) fprintf(dbgfile, "%ld:\t%d\t\t\t\t# %s\n", (long)pc, op, name);#else /* DeBugLinker */#if MACINTOSH && MPW/* #pragma unused(name) */#endif /* MACINTOSH && MPW */#endif /* DeBugLinker */ outop(op); }static novalue lemitl(op, lab, name)int op, lab;char *name; {#ifdef DeBugLinker if (Dflag) fprintf(dbgfile, "%ld:\t%d\tL%d\t\t\t# %s\n", (long)pc, op, lab, name);#else /* DeBugLinker */#if MACINTOSH && MPW/* #pragma unused(name) */#endif /* MACINTOSH && MPW */#endif /* DeBugLinker */ if (lab >= maxlabels) quit("out of label space"); outop(op); if (labels[lab] <= 0) { /* forward reference */ outword(labels[lab]); labels[lab] = WordSize - pc; /* add to front of reference chain */ } else /* output relative offset */ outword(labels[lab] - (pc + WordSize)); }static novalue lemitn(op, n, name)int op;word n;char *name; {#ifdef DeBugLinker if (Dflag) fprintf(dbgfile, "%ld:\t%d\t%ld\t\t\t# %s\n", (long)pc, op, (long)n, name);#else /* DeBugLinker */#if MACINTOSH && MPW/* #pragma unused(name) */#endif /* MACINTOSH && MPW */#endif /* DeBugLinker */ outop(op); outword(n); }static novalue lemitr(op, loc, name)int op;word loc;char *name; { loc -= pc + ((IntBits/ByteBits) + WordSize);#ifdef DeBugLinker if (Dflag) { if (loc >= 0) fprintf(dbgfile, "%ld:\t%d\t*+%ld\t\t\t# %s\n",(long) pc, op, (long)loc, name); else fprintf(dbgfile, "%ld:\t%d\t*-%ld\t\t\t# %s\n",(long) pc, op, (long)-loc, name); }#else /* DeBugLinker */#if MACINTOSH && MPW/* #pragma unused(name) */#endif /* MACINTOSH && MPW */#endif /* DeBugLinker */ outop(op); outword(loc); }static novalue lemitin(op, offset, n, name)int op, n;word offset;char *name; {#ifdef DeBugLinker if (Dflag) fprintf(dbgfile, "%ld:\t%d\t%d,I+%ld\t\t\t# %s\n", (long)pc, op, n, (long)offset, name);#else /* DeBugLinker */#if MACINTOSH && MPW/* #pragma unused(name) */#endif /* MACINTOSH && MPW */#endif /* DeBugLinker */ outop(op); outword(n); outword(offset); }/* * lemitint can have some pitfalls. outword is used to output the * integer and this is picked up in the interpreter as the second * word of a short integer. The integer value output must be * the same size as what the interpreter expects. See op_int and op_intx * in interp.s */static novalue lemitint(op, i, name)int op;long i;char *name; {#ifdef DeBugLinker if (Dflag) fprintf(dbgfile,"%ld:\t%d\t%ld\t\t\t# %s\n",(long)pc,op,(long)i,name);#else /* DeBugLinker */#if MACINTOSH && MPW/* #pragma unused(name) */#endif /* MACINTOSH && MPW */#endif /* DeBugLinker */ outop(op); outword(i); }static novalue lemiteven() { word x = 0; register int len; if (len = pc % (IntBits/ByteBits)) outblock((char *)x, (IntBits/ByteBits) - len); }static novalue lemitcon(k)register int k; { register int i, j; register char *s; int csbuf[CsetSize]; union { char ovly[1]; /* Array used to overlay l and f on a bytewise basis. */ long l; double f; } x; if (lctable[k].c_flag & F_RealLit) {#ifdef Double/* access real values one word at a time */ { int *rp, *rq; rp = (int *) &(x.f); rq = (int *) &(lctable[k].c_val.rval); *rp++ = *rq++; *rp = *rq; }#else /* Double */ x.f = lctable[k].c_val.rval;#endif /* Double */#ifdef DeBugLinker if (Dflag) { fprintf(dbgfile, "%ld:\t%d\n", (long)pc, T_Real); dumpblock(x.ovly,sizeof(double)); fprintf(dbgfile, "\t\t\t( %g )\n",x.f); }#endif /* DeBugLinker */ outword(T_Real);#ifdef Double/* fill out real block with an empty word */ outword(0);#endif /* Double */ outblock(x.ovly,sizeof(double)); } else if (lctable[k].c_flag & F_CsetLit) { for (i = 0; i < CsetSize; i++) csbuf[i] = 0; s = lctable[k].c_val.sval; i = lctable[k].c_length; while (i--) { Setb(ToAscii(*s), csbuf); s++; } j = 0; for (i = 0; i < 256; i++) { if (Testb(i, csbuf)) j++; }#ifdef DeBugLinker if (Dflag) { fprintf(dbgfile, "%ld:\t%d\n",(long) pc, T_Cset);
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:icont Folder:lcode.
+++++ Continued from previous card +++++
fprintf(dbgfile, "\t%d\n",j); fprintf(dbgfile,(char *)csbuf,sizeof(csbuf)); }#endif /* DeBugLinker */ outword(T_Cset); outword(j); /* cset size */ outblock((char *)csbuf,sizeof(csbuf));#ifdef DeBugLinker if (Dflag) dumpblock((char *)csbuf,CsetSize);#endif /* DeBugLinker */ } }static novalue lemitproc(name, nargs, ndyn, nstat, fstat)char *name;int nargs, ndyn, nstat, fstat; { register int i; register char *p; int size; /* * FncBlockSize = sizeof(BasicFncBlock) + * sizeof(descrip)*(# of args + # of dynamics + # of statics). */ size = (9*WordSize) + (2*WordSize) * (abs(nargs)+ndyn+nstat);#ifdef DeBugLinker if (Dflag) { fprintf(dbgfile, "%ld:\t%d\n", (long)pc, T_Proc); /* type code */ fprintf(dbgfile, "\t%d\n", size); /* size of block */ fprintf(dbgfile, "\tZ+%ld\n",(long)(pc+size)); /* entry point */ fprintf(dbgfile, "\t%d\n", nargs); /* # arguments */ fprintf(dbgfile, "\t%d\n", ndyn); /* # dynamic locals */ fprintf(dbgfile, "\t%d\n", nstat); /* # static locals */ fprintf(dbgfile, "\t%d\n", fstat); /* first static */ fprintf(dbgfile, "\t%d\tI+%ld\t\t\t# %s\n", /* name of procedure */ (int)strlen(name), (long)(name-lsspace), name); }#endif /* DeBugLinker */ outword(T_Proc); outword(size); outword(pc + size - 2*WordSize); /* Have to allow for the two words that we've already output. */ outword(nargs); outword(ndyn); outword(nstat); outword(fstat); outword(strlen(name)); outword(name - lsspace); /* * Output string descriptors for argument names by looping through * all locals, and picking out those with F_Argument set. */ for (i = 0; i <= nlocal; i++) { if (lltable[i].l_flag & F_Argument) { p = lltable[i].l_name;#ifdef DeBugLinker if (Dflag) fprintf(dbgfile, "\t%d\tI+%ld\t\t\t# %s\n", (int)strlen(p), (long)(p-lsspace), p);#endif /* DeBugLinker */ outword(strlen(p)); outword(p - lsspace); } } /* * Output string descriptors for local variable names. */ for (i = 0; i <= nlocal; i++) { if (lltable[i].l_flag & F_Dynamic) { p = lltable[i].l_name;#ifdef DeBugLinker if (Dflag) fprintf(dbgfile, "\t%d\tI+%ld\t\t\t# %s\n", (int)strlen(p), (long)(p-lsspace), p);#endif /* DeBugLinker */ outword(strlen(p)); outword(p - lsspace); } } /* * Output string descriptors for local variable names. */ for (i = 0; i <= nlocal; i++) { if (lltable[i].l_flag & F_Static) { p = lltable[i].l_name;#ifdef DeBugLinker if (Dflag) fprintf(dbgfile, "\t%d\tI+%ld\t\t\t# %s\n", (int)strlen(p), (long)(p-lsspace), p);#endif /* DeBugLinker */ outword(strlen(p)); outword(p - lsspace); } } } /* * gentables - generate interpreter code for global, static, * identifier, and record tables, and built-in procedure blocks. */novalue gentables() { register int i; register char *s; register struct gentry *gp; struct fentry *fp; struct rentry *rp; struct header hdr;#if MVS FILE *toutfile; /* temporary file for icode output */#endif /* MVS */ lemiteven(); /* * Output record constructor procedure blocks. */ hdr.records = pc;#ifdef DeBugLinker if (Dflag) fprintf(dbgfile, "%ld:\t%d\t\t\t\t# record blocks\n",(long)pc, nrecords);#endif /* DeBugLinker */ outword(nrecords); for (gp = lgtable; gp < lgfree; gp++) { if (gp->g_flag & (F_Record & ~F_Global)) { s = gp->g_name; gp->g_pc = pc;#ifdef DeBugLinker if (Dflag) { fprintf(dbgfile, "%ld:\n", pc); fprintf(dbgfile, "\t%d\n", T_Proc); fprintf(dbgfile, "\t%d\n", RkBlkSize); fprintf(dbgfile, "\t_mkrec\n"); fprintf(dbgfile, "\t%d\n", gp->g_nargs); fprintf(dbgfile, "\t-2\n"); fprintf(dbgfile, "\t%d\n", gp->g_procid); fprintf(dbgfile, "\t1\n"); fprintf(dbgfile, "\t%d\tI+%ld\t\t\t# %s\n", (int)strlen(s), (long)(s-lsspace), s); }#endif /* DeBugLinker */ outword(T_Proc); /* type code */ outword(RkBlkSize); /* size of block */ outword(0); /* entry point (filled in by interp)*/ outword(gp->g_nargs); /* number of fields */ outword(-2); /* record constructor indicator */ outword(gp->g_procid); /* record id */ outword(1); /* serial number */ outword(strlen(s)); /f record */ outword(s - lsspace); } } /* * Output record/field table. */ hdr.ftab = pc;#ifdef DeBugLinker if (Dflag) fprintf(dbgfile, "%ld:\t\t\t\t\t# record/field table\n", (long)pc);#endif /* DeBugLinker */ for (fp = lftable; fp < lffree; fp++) {#ifdef DeBugLinker if (Dflag) fprintf(dbgfile, "%ld:\n", (long)pc);#endif /* DeBugLinker */ rp = fp->f_rlist; for (i = 1; i <= nrecords; i++) { if (rp != NULL && rp->r_recid == i) {#ifdef DeBugLinker if (Dflag) fprintf(dbgfile, "\t%d\n", rp->r_fnum);#endif /* DeBugLinker */ outword(rp->r_fnum); rp = rp->r_link; } else {#ifdef DeBugLinker if (Dflag) fprintf(dbgfile, "\t-1\n");#endif /* DeBugLinker */ outword(-1); }#ifdef DeBugLinker if (Dflag && (i == nrecords || (i & 03) == 0)) putc('\n', dbgfile);#endif /* DeBugLinker */ } } /* * Output descriptors for field names. */ hdr.fnames = pc; for (fp = lftable; fp < lffree; fp++) { s = fp->f_name;#ifdef DeBugLinker if (Dflag) fprintf(dbgfile, "%ld:\t%d\tI+%ld\t\t\t# %s\n", (long)pc, (int)strlen(s), (long)(s-lsspace), s);#endif /* DeBugLinker */ outword(strlen(s)); /* name of field */ outword(s - lsspace); } /* * Output global variable descriptors. */ hdr.globals = pc; for (gp = lgtable; gp < lgfree; gp++) { if (gp->g_flag & (F_Builtin & ~F_Global)) { /* function */#ifdef DeBugLinker if (Dflag) fprintf(dbgfile, "%ld:\t%06lo\t%d\t\t\t# %s\n", (long)pc, (long)D_Proc, -gp->g_procid, gp->g_name);#endif /* DeBugLinker */ outword(D_Proc); outword(-gp->g_procid); } else if (gp->g_flag & (F_Proc & ~F_Global)) { /* Icon procedure */#ifdef DeBugLinker if (Dflag) fprintf(dbgfile, "%ld:\t%06lo\tZ+%ld\t\t\t# %s\n", (long)pc,(long)D_Proc, (long)gp->g_pc, gp->g_name);#endif /* DeBugLinker */ outword(D_Proc); outword(gp->g_pc); } else if (gp->g_flag & (F_Record & ~F_Global)) { /* record constructor */#ifdef DeBugLinker if (Dflag) fprintf(dbgfile, "%ld:\t%06lo\tZ+%ld\t\t\t# %s\n", (long)pc, (long)D_Proc, (long)gp->g_pc, gp->g_name);#endif /* DeBugLinker */ outword(D_Proc); outword(gp->g_pc); } else { /* global variable */#ifdef DeBugLinker if (Dflag) fprintf(dbgfile, "%ld:\t%06lo\t0\t\t\t# %s\n",(long)pc, (long)D_Null, gp->g_name);#endif /* DeBugLinker */ outword(D_Null); outword(0); } } /* * Output descriptors for global variable names. */ hdr.gnames = pc; for (gp = lgtable; gp < lgfree; gp++) {#ifdef DeBugLinker if (Dflag) fprintf(dbgfile, "%ld:\t%d\tI+%ld\t\t\t# %s\n", (long)pc, (int)strlen(gp->g_name), (long)(gp->g_name-lsspace), gp->g_name);#endif /* DeBugLinker */ outword(strlen(gp->g_name)); outword(gp->g_name - lsspace); } /* * Output a null descriptor for each static variable. */ hdr.statics = pc; for (i = lstatics; i > 0; i--) {#ifdef DeBugLinker if (Dflag) fprintf(dbgfile, "%ld:\t0\t0\n", (long)pc);#endif /* DeBugLinker */ outword(D_Null); outword(0); } flushcode(); /* * Output the string constant table and the two tables associating icode * locations with source program locations. Note that the calls to write * really do all the work. */#ifdef DeBugLinker if (Dflag) { for (s = lsspace; s < lsfree; ) { fprintf(dbgfile, "%ld:\t%03o\n", (long)pc, *s++); for (i = 7; i > 0; i--) { if (s >= lsfree) break; fprintf(dbgfile, " %03o\n", *s++); } putc('\n', dbgfile); } }#endif /* DeBugLinker */ hdr.filenms = pc; pc += (char *)fnmfree - (char *)fnmtbl; hdr.linenums = pc; pc += (char *)lnfree - (char *)lntable; hdr.strcons = pc; pc += lsfree - lsspace; if (longwrite((char *)fnmtbl, (long)((char *)fnmfree - (char *)fnmtbl), outfile) < 0) quit("cannot write icode file"); if (longwrite((char *)lntable, (long)((char *)lnfree - (char *)lntable), outfile) < 0) quit("cannot write icode file"); if (longwrite(lsspace, (long)(lsfree - lsspace), outfile) < 0) quit("cannot write icode file"); /* * Output icode file header. */ hdr.hsize = pc; strcpy((char *)hdr.config,IVersion); hdr.trace = trace;#ifdef DeBugLinker if (Dflag) { fprintf(dbgfile, "size: %ld\n", (long)hdr.hsize); fprintf(dbgfile, "trace: %ld\n", (long)hdr.trace); fprintf(dbgfile, "records: %ld\n", (long)hdr.records); fprintf(dbgfile, "ftab: %ld\n", (long)hdr.ftab); fprintf(dbgfile, "fnames: %ld\n", (long)hdr.fnames); fprintf(dbgfile, "globals: %ld\n", (long)hdr.globals); fprintf(dbgfile, "gnames: %ld\n", (long)hdr.gnames); fprintf(dbgfile, "statics: %ld\n", (long)hdr.statics); fprintf(dbgfile, "strcons: %ld\n", (long)hdr.strcons); fprintf(dbgfile, "filenms: %ld\n", (long)hdr.filenms); fprintf(dbgfile, "linenums: %ld\n", (long)hdr.linenums); fprintf(dbgfile, "config: %s\n", hdr.config); }#endif /* DeBugLinker */#ifdef Header fseek(outfile, (long)MaxHeader, 0);#else /* Header */#if MVS/* * This kind of backpatching cannot work on a PDS member, and that's * probably where the code is going. So the code goes out first to * a temporary file, and then copied to the real icode file after * the header is written. */ fseek(outfile, sizeof(hdr), SEEK_SET); toutfile = outfile; outfile = fopen(routname, "wb"); if (outfile == NULL) quitf("cannot create %s",routname);#else fseek(outfile, 0L, 0);#endif /* MVS */#endif /* Header */ if (longwrite((char *)&hdr, (long)sizeof(hdr), outfile) < 0) quit("cannot write icode file");#if MVS { char *allelse = malloc(hdr.hsize); if (hdr.hsize != fread(allelse, 1, hdr.hsize, toutfile) || longwrite(allelse, hdr.hsize, outfile) < 0) quit("cannot write icode file"); free(allelse); fclose(toutfile); }#endif /* MVS */ } /* * intout(i) outputs i as an int that is used by the runtime system * IntBits/ByteBits bytes must be moved from &word[0] to &codep[0]. */static novalue intout(oint)int oint; { int i; union { int i; char c[IntBits/ByteBits]; } u; CodeCheck(1); u.i = oint; for (i = 0; i < IntBits/ByteBits; i++) codep[i] = u.c[i]; codep += IntBits/ByteBits; pc += IntBits/ByteBits; } /* * wordout(i) outputs i as a word that is used by the runtime system * WordSize bytes must be moved from &oword[0] to &codep[0]. */static novalue wordout(oword)word oword; { int i; union { word i; char c[WordSize]; } u; CodeCheck(1); u.i = oword; for (i = 0; i < WordSize; i++) codep[i] = u.c[i]; codep += WordSize; pc += WordSize; } /* * outblock(a,i) output i bytes starting at address a. */static novalue outblock(addr,count)char *addr;int count; { CodeCheck(count); pc += count; while (count--) *codep++ = *addr++; } #ifdef DeBugLinker/* * dumpblock(a,i) dump contents of i bytes at address a, used only * in conjunction with -L. */static novalue dumpblock(addr, count)char *addr;int count; { int i; for (i = 0; i < count; i++) { if ((i & 7) == 0) fprintf(dbgfile,"\n\t"); fprintf(dbgfile," %03o\n",(0377 & (unsigned)addr[i])); } putc('\n',dbgfile); }#endif /* DeBugLinker */ /* * flushcode - write buffered code to the output file. */static novalue flushcode() { if (codep > codeb) if (longwrite(codeb, (long)codep - (long)codeb, outfile) < 0) quit("cannot write icode file"); codep = codeb; } /* * clearlab - clear label table to all zeroes. */static novalue clearlab() { register int i; for (i = 0; i < maxlabels; i++) labels[i] = 0; } /* * backpatch - fill in all forward references to lab. */static novalue backpatch(lab)int lab; { word p, r; char *q; char *cp, *cr; register int j; if (lab >= maxlabels) quit("out of label space"); p = labels[lab]; if (p > 0) quit("multiply defined label in ucode"); while (p < 0) { /* follow reference chain */ r = pc - (WordSize - p); /* compute relative offset */ q = codep - (pc + p); /* point to word with address */ cp = (char *) &p; /* address of integer p */ cr = (char *) &r; /* address of integer r */ for (j = 0; j < WordSize; j++) { /* move bytes from word pointed to */ *cp++ = *q; /* by q to p, and move bytes from */ *q++ = *cr++; /* r to word pointed to by q */ } /* moves integers at arbitrary addresses */ } labels[lab] = pc; } #ifdef DeBugLinkernovalue idump(s) /* dump code region */ char *s; { int *c; fprintf(stderr,"\ndump of code region %s:\n",s); for (c = (int *)codeb; c < (int *)codep; c++) fprintf(stderr,"%ld: %d\n",(long)c, (int)*c); fflush(stderr); }#endif /* DeBugLinker */ :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:icont Folder:lfile.h
/* * A linked list of files named by link declarations is maintained using * lfile structures. */struct lfile { char *lf_name; /* name of the file */ struct lfile *lf_link; /* pointer to next file */ };extern struct lfile *lfiles; :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:icont Folder:lglob.c
/* * lgloc.c -- routines for processing .u2 files. */#include "::h:config.h"#include "tproto.h"#include "link.h"#include "opcode.h"#include "::h:version.h"int nrecords = 0; /* number of records in program *//* * readglob reads the global information from infile (.u2) and merges it with * the global table and record table. */novalue readglob() { register char *id; register int n, op; int k; int implicit; char *name; struct gentry *gp; extern char *progname; if (getopc(&name) != Op_Version) quitf("ucode file %s has no version identification",inname); id = getid(); /* get version number of ucode */ newline(); if (strcmp(id,UVersion)) { fprintf(stderr,"version mismatch in ucode file %s\n",inname); fprintf(stderr,"\tucode version: %s\n",id); fprintf(stderr,"\texpected version: %s\n",UVersion); exit(ErrorExit); } while ((op = getopc(&name)) != EOF) { switch (op) { case Op_Record: /* a record declaration */ id = getid(); /* record name */ n = getdec(); /* number of fields */ newline(); gp = glocate(id); /* * It's ok if the name isn't already in use or if the * name is just used in a "global" declaration. Otherwise, * it is an inconsistent redeclaration. */ if (gp == NULL || (gp->g_flag & ~F_Global) == 0) { putglobal(id, F_Record, n, ++nrecords); while (n--) { /* loop reading field numbers and names */ k = getdec(); putfield(getid(), nrecords, k); newline(); } } else { lfatal(id, "inconsistent redeclaration"); while (n--) newline(); } break; case Op_Impl: /* undeclared identifiers should be noted */ if (getopc(&name) == Op_Local) implicit = 0; else implicit = F_ImpError; break; case Op_Trace: /* turn on tracing */ trace = -1; break; case Op_Global: /* global variable declarations */ n = getdec(); /* number of global declarations */ newline(); while (n--) { /* process each declaration */ getdec(); /* throw away sequence number */ k = getoct(); /* get flags */ if (k & (F_Proc & ~F_Global)) k |= implicit; id = getid(); /* get variable name */ gp = glocate(id); /* * Check for conflicting declarations and install the * variable. */ if (gp != NULL && (k & (F_Proc & ~F_Global)) && gp->g_flag != F_Global) lfatal(id, "inconsistent redeclaration"); else if (gp == NULL || (k & (F_Proc & ~F_Global))) putglobal(id, k, getdec(), 0); newline(); } break; case Op_Link: /* link the named file */ name = getrest(); /* get the name and *//* name = getstr(); /* get the name and */ alsolink(name); /* put it on the list of files to link */ newline(); break; default: quitf("ill-formed global file %s",inname); } } } :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:icont Folder:link.c
/* * link.c -- linker main program that controls the linking process. */#include "::h:config.h"#include "tproto.h"#include "globals.h"#include "link.h"#include "general.h"#include "::h:paths.h"#include "::h:header.h"#ifdef Header#include "hdr.h"#ifndef MaxHeader#define MaxHeader MaxHdr#endif /* MaxHeader */#endif /* Header *//* * The following code is operating-system dependent [@link.01]. Include * system-dependent files and declarations. */#if PORT /* nothing to do */Deliberate Syntax Error#endif /* PORT */#if AMIGA || ATARI_ST || HIGHC_386 || MACINTOSH || VM || VMS /* nothing to do */#endif /* AMIGA || ATARI_ST || HIGHC_386 ... */#if MSDOS#if MICROSOFT || TURBO#include <fcntl.h>#endif /* MICROSOFT || TURBO */#endif /* MSDOS */#if MVSchar *routname; /* real output file name */#endif /* MVS */#if OS2#if MICROSOFT#include <fcntl.h>#endif /* MICROSOFT */#endif /* OS2 */#if UNIX#include <sys/types.h>#include <sys/stat.h>#endif /* UNIX *//* * End of operating-system specific code. */FILE *infile; /* input file (.u1 or .u2) */FILE *outfile; /* interpreter code output file */#ifdef DeBugLinkerFILE *dbgfile; /* debug file */static char dbgname[MaxFileName]; /* debug file name */#endif /* DeBugLinker */char inname[MaxFileName]; /* input file name */static char icnname[MaxFileName]; /* icon source file name */struct lfile *llfiles = NULL; /* List of files to link */#ifdef EvalTraceint colmno = 0; /* current source program colm number */#endif /* EvalTrace */int lineno = 0; /* current source program line number */int fatals = 0; /* number of errors encountered */ /* * ilink - link a number of files, returning error count */int ilink(ifiles,outname)char **ifiles;char *outname; { int i; struct lfile *lf,*lfls; char *filename; /* name of current input file */ linit(); /* initialize memory structures */ while (*ifiles) alsolink(*ifiles++); /* make initial list of files */ /* * Phase I: load global information contained in .u2 files into * data structures. * * The list of files to link is maintained as a queue with llfiles * as the base. lf moves along the list. Each file is processed * in turn by forming .u2 and .icn names from each file name, each * of which ends in .u1. The .u2 file is opened and globals is called * to process it. When the end of the list is reached, lf becomes * NULL and the loop is terminated, completing phase I. Note that * link instructions in the .u2 file cause files to be added to list * of files to link. */ for (lf = llfiles; lf != NULL; lf = lf->lf_link) { filename = lf->lf_name; makename(inname, SourceDir, filename, U2Suffix); makename(icnname, TargetDir, filename, SourceSuffix);#if MVS || VM/* * Even though the ucode data is all reasonable text characters, use * of text I/O may cause problems if a line is larger than LRECL. * This is likely to be true with any compiler, though the precise * disaster which results may vary. */ infile = fopen(inname, ReadBinary);#else infile = fopen(inname, "r");#endif /* MVS || VM */ if (infile == NULL) quitf("cannot open %s",inname); readglob(); fclose(infile); } /* Phase II: resolve undeclared variables and generate code. */ /* * Open the output file. */#ifdef WATERLOO_C_V3_0 strcat(outname," (BIN");#endif /* WATERLOO_C_V3_0 */#if MVS routname = outname; outfile = tmpfile(); /* write icode to temporary file to avoid fseek-PDS limitations */#else /* MVS */ outfile = fopen(outname, WriteBinary);#endif /* MVS *//* * The following code is operating-system dependent [@link.02]. Set * untranslated mode if necessary. */#if PORT /* probably nothing */Deliberate Syntax Error#endif /* PORT */#if AMIGA || ATARI_ST || HIGHC_386 || MACINTOSH || MVS || UNIX || VM || VMS /* nothing to do */#endif /* AMIGA || ATARI_ST || ... */#if MSDOS#if LATTICE fmode(outfile,1); /* set for untranslated mode */#endif /* LATTICE */#if MICROSOFT || TURBO setmode(fileno(outfile),O_BINARY); /* set for untranslated mode */#endif /* MICROSOFT || TURBO */#endif /* MSDOS */#if OS2#if MICROSOFT setmode(fileno(outfile),O_BINARY);#endif /* MICROSOFT */#endif /* OS2 *//* * End of operating-system specific code. */ if (outfile == NULL) quitf("cannot create %s",outname);#ifdef Header /* * Open Header, which contains the start-up program and copy it to the * output file. Then, write out null bytes to past the end of the * start-up program. */ { int hsize; char hname[MaxFileName]; char hdrdat[MaxHeader+1];#if (MACINTOSH && MPW) { int i; fwrite(iconxhdr, sizeof(char), sizeof iconxhdr, outfile); for (i = MaxHeader - sizeof iconxhdr;i;--i) fputc(0,outfile); }#else /* (MACINTOSH && MPW) */ fwrite(iconxhdr, sizeof(char), MaxHeader, outfile);#endif /* (MACINTOSH && MPW) */ }#endif /* Header */ for (i = sizeof(struct header); i--;) putc(0, outfile); fflush(outfile); if (ferror(outfile) != 0) quit("unable to write to icode file");#ifdef DeBugLinker /* * Open the .ux file if debugging is on. */ if (Dflag) { makename(dbgname, TargetDir, llfiles->lf_name, ".ux"); dbgfile = fopen(dbgname, "w"); if (dbgfile == NULL) quitf("cannot create %s", dbgname); }#endif /* DeBugLinker */ /* * Loop through input files and generate code for each. */ lfls = llfiles; while (lf = getlfile(&lfls)) { filename = lf->lf_name; makename(inname, SourceDir, filename, U1Suffix); makename(icnname, TargetDir, filename, SourceSuffix);#if MVS || VM infile = fopen(inname, ReadBinary);#else /* MVS || VM */ infile = fopen(inname, "r");#endif /* MVS || VM */ if (infile == NULL) quitf("cannot open %s", inname); gencode(); fclose(infile); } gentables(); /* Generate record, field, global, global names, static, and identifier tables. */ fclose(outfile); lmfree(); if (fatals > 0) return fatals; setexe(outname); return 0; } /* * lwarn - issue a linker warning message. */novalue lwarn(s1, s2, s3)char *s1, *s2, *s3; { fprintf(stderr, "%s: ", icnname); if (lineno) fprintf(stderr, "Line %d # :", lineno); fprintf(stderr, "\"%s\": %s%s\n", s1, s2, s3); fflush(stderr); } /* * lfatal - issue a fatal linker error message. */novalue lfatal(s1, s2)char *s1, *s2; { fprintf(stderr, "%s: ", icnname); if (lineno) fprintf(stderr, "Line %d # : ", lineno); fprintf(stderr, "\"%s\": %s\n", s1, s2); fatals++; } /* * setexe - mark the output file as executable */static novalue setexe(fname)char *fname; {/* * The following code is operating-system dependent [@link.03]. It changes the * mode of executable file so that it can be executed directly. */#if PORT /* something is needed */Deliberate Syntax Error#endif /* PORT */#if AMIGA /* not necessary */#endif /* AMIGA */#if ATARI_ST || MSDOS || MVS || OS2 || VM || VMS /* can't be made executable */ /* note: VMS files can't be made executable, but see "iexe.com" under VMS. */#endif /* ATARI_ST || MSDOS || VMS */#if HIGHC_386 /* not implemented yet. */#endif /* HIGHC_386 */#if MACINTOSH#if MPW /* Nothing to do here -- file is set to type TEXT (so it can be executed as a script) in tmain.c. *//* #pragma unused(fname) */#endif /* MPW */#endif /* MACINTOSH */#if MSDOS#if LATTICE || MICROSOFT || TURBO chmod(fname,0755); /* probably could be smarter... */#endif /* LATTICE || MICROSOFT || TURBO */#if MWC /* can't handle */#endif /* MWC */#endif /* MSDOS */#if UNIX { struct stat stbuf; int u, r, m; /* * Set each of the three execute bits (owner,group,other) if allowed by * the current umask and if the corresponding read bit is set; do not * clear any bits already set. */ umask(u = umask(0)); /* get and restore umask */ if (stat(fname,&stbuf) == 0) { /* must first read existing mode */ r = (stbuf.st_mode & 0444) >> 2; /* get & position read bits */ m = stbuf.st_mode | (r & ~u); /* set execute bits */ chmod(fname,m); /* change file mode */ } }#endif /* UNIX *//* * End of operating-system specific code. */ } :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:icont Folder:link.h
/* * External declarations for the linker. */#include "::h:rt.h"#ifdef ATT3B#include <sys/types.h>#include <sys/stat.h>#endif /* ATT3B *//* * Miscellaneous external declarations. */extern FILE *infile; /* current input file */extern FILE *outfile; /* linker output file */extern FILE *dbgfile; /* debug file */extern char inname[]; /* input file name */extern int lineno; /* source program line number (from ucode) */#ifdef EvalTraceextern int colmno; /* source program column number */#endif /* EvalTrace */extern int lstatics; /* total number of statics */extern int argoff; /* stack offset counter for arguments */extern int dynoff; /* stack offset counter for locals */extern int static1; /* first static in procedure */extern int nlocal; /* number of locals in local table */extern int nconst; /* number of constants in constant table */extern int nrecords; /* number of records in program */extern int trace; /* initial setting of &trace */extern char ixhdr[]; /* header line for direct execution */extern char *iconx; /* location of iconx */extern int hdrloc; /* location to place hdr block at */extern struct lfile *llfiles; /* list of files to link *//* * Structures for symbol table entries. */struct lentry { /* local table entry */ char *l_name; /* name of variable */ int l_flag; /* variable flags */ union { /* value field */ int staticid; /* unique id for static variables */ word offset; /* stack offset for args and locals */ struct gentry *global; /* global table entry */ } l_val; };struct gentry { /* global table entry */ struct gentry *g_blink; /* link for bucket chain */ char *g_name; /* name of variable */ int g_flag; /* variable flags */ int g_nargs; /* number of args or fields */ int g_procid; /* procedure or record id */ word g_pc; /* position in icode of object */ };struct centry { /* constant table entry */ int c_flag; /* type of literal flag */ union { /* value field */ long ival; /* integer */ double rval; /* real */ char *sval; /* string */ } c_val; int c_length; /* length of literal string */ word c_pc; /* position in icode of object */ };struct ientry { /* identifier table entry */ struct ientry *i_blink; /* link for bucket chain */ char *i_name; /* pointer to string */ int i_length; /* length of string */ };struct fentry { /* field table header entry */ struct fentry *f_blink; /* link for bucket chain */ char *f_name; /* name of field */ int f_fid; /* field id */ struct rentry *f_rlist; /* head of list of records */ };struct rentry { /* field table record list entry */ struct rentry *r_link; /* link for list of records */ int r_recid; /* record id */ int r_fnum; /* offset of field within record */ };/* * Structure for linked list of file names to link. */struct lfile { struct lfile *lf_link; /* next file in list */ char *lf_name; /* name of file */ };union xval { long ival; double rval; char *sval; };/* * Flag values in symbol tables. */#define F_Global 01 /* variable declared global externally */#define F_Proc 05 /* procedure (includes GLOBALfine F_Record 011 /* record (includes GLOBAL) */#define F_Dynamic 020 /* variable declared local dynamic */#define F_Static 040 /* variable declared local static */#define F_Builtin 0101 /* identifier refers to built-in procedure */#define F_ImpError 0400 /* procedure has default error */#define F_Argument 01000 /* variable is a formal parameter */#define F_IntLit 02000 /* literal is an integer */#define F_RealLit 04000 /* literal is a real */#define F_StrLit 010000 /* literal is a string */#define F_CsetLit 020000 /* literal is a cset *//* * Symbol table region pointers. */extern struct gentry **lghash; /* hash area for global table */extern struct ientry **lihash; /* hash area for identifier table */extern struct fentry **lfhash; /* hash area for field table */extern struct lentry *lltable; /* local table */extern struct gentry *lgtable; /* global table */extern struct centry *lctable; /* constant table */extern struct ientry *litable; /* identifier table */extern struct fentry *lftable; /* field table headers */extern struct rentry *lrtable; /* field table record lists */extern struct ipc_fname *fnmtbl; /* table associating ipc with file name */extern struct ipc_line *lntable; /* table associating ipc with line number */extern char *lsspace; /* string space */extern word *labels; /* label table */extern char *codeb; /* generated code space */extern struct gentry *lgfree; /* free pointer for global table */extern struct ientry *lifree; /* free pointer for identifier table */extern struct fentry *lffree; /* free pointer for field table headers */extern struct rentry *lrfree; /* free pointer for field table record lists */extern struct ipc_fname *fnmfree; /* free pointer for ipc/file name tbl */extern struct ipc_line *lnfree; /* free pointer for ipc/line number tbl */extern char *lsfree; /* free pointer for string space */extern char *codep; /* free pointer for code space */extern char *lsend; /* pointer to end of string space *//* * Hash computation macros. */#define ghasher(x) (((word)x)&gmask) /* for global table */#define fhasher(x) (((word)x)&fmask) /* for field table *//* * Machine-dependent constants. */#define RkBlkSize 9*WordSize /* size of record constructor block */ :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:icont Folder:llex.c
/* * llex.c -- lexical analysis routines. */#ifdef CRAY#include <stdlib.h>#endif /* CRAY */#include <math.h>#include "::h:config.h"#include "general.h"#include "tproto.h"#include "link.h"#include "opcode.h"#include <ctype.h>int nlflag = 0; /* newline last seen */#if MACINTOSH#if MPW#include <CursorCtl.h>#define CURSORINTERVAL 100#endif /* MPW */#endif /* MACINTOSH */#if !EBCDIC#define tonum(c) (isdigit(c) ? (c - '0') : ((c & 037) + 9))#endif /* !EBCDIC */ #if !EBCDIC/* * getopc - get an opcode from infile, return the opcode number (via * binary search of opcode table), and point id at the name of the opcode. */int getopc(id)char **id; { register char *s; register struct opentry *p; register int test; int low, high, cmp; extern char *getstr(); s = getstr(); if (s == NULL) return EOF; low = 0; high = NOPCODES; do { test = (low + high) / 2; p = &optable[test]; if ((cmp = strcmp(p->op_name, s)) < 0) low = test + 1; else if (cmp > 0) high = test; else { *id = p->op_name; return (p->op_code); } } while (low < high); *id = s; return 0; }#else /* !EBCDIC *//* * getopc - get an opcode from infile, return the opcode number (via * sequential search of opcode table) and point id at the name of the opcode. */ int getopc(id)char **id; { register char *s; register struct opentry *p; register int test; s = getstr(); if (s == NULL) return EOF; for(test=0;test < NOPCODES; test++) { p = &optable[test]; if( strcmp(p->op_name, s) == 0) { *id = p->op_name; return (p->op_code); } } *id = s; return 0; }#endif /* !EBCDIC */ /* * getid - get an identifier from infile, put it in the identifier * table, and return a pointer to it. */char *getid() { register char *s; s = getstr(); if (s == NULL) return NULL; return putident((int)strlen(s)+1); } /* * getstr - get an identifier from infile and return a pointer to it. */char *getstr() { register int c; register char *p;#if MACINTOSH#if MPW { static short cursorcount = CURSORINTERVAL; if (--cursorcount == 0) { RotateCursor(-32); cursorcount = CURSORINTERVAL; } }#endif /* MPW */#endif /* MACINTOSH */ p = lsfree; while ((c = getc(infile)) == ' ' || c == '\t') ; if (c == EOF) return NULL; while (c != ' ' && c != '\t' && c != '\n' && c != ',' && c != EOF) { if (p >= lsend) quit("out of string space"); *p++ = c; c = getc(infile); } *p = 0; nlflag = (c == '\n'); return lsfree; } /* * getrest - get the rest of the line from infile, put it in the identifier * table, and return a pointer to it. */char *getrest() { register int c; register char *p; p = lsfree; while ((c = getc(infile)) != '\n' && c != EOF) { if (p >= lsend) quit("out of string space"); *p++ = c; } *p = 0; nlflag = (c == '\n'); return putident((int)strlen(lsfree)+1); } /* * getdec - get a decimal integer from infile, and return it. */int getdec() { register int c, n; int sign = 1; n = 0; while ((c = getc(infile)) == ' ' || c == '\t') ; if (c == EOF) return 0; if (c == '-') { sign = -1; c = getc(infile); } while (c >= '0' && c <= '9') { n = n * 10 + (c - '0'); c = getc(infile); } nlflag = (c == '\n'); return n*sign; } /* * getoct - get an octal number from infile, and return it. */int getoct() { register int c, n; n = 0; while ((c = getc(infile)) == ' ' || c == '\t') ; if (c == EOF) return 0; while (c >= '0' && c <= '7') { n = (n << 3) | (c - '0'); c = getc(infile); } nlflag = (c == '\n'); return n; } /* * Get integer, but if it's too large for a long, put the string via cp * and return -1. */long getint(j,cp) int j; char **cp; { register int c; int over = 0; register char *p; double result = 0; long lresult = 0; double radix; if (lsfree + j > lsend) quit("out of string space"); p = lsfree; while ((c = getc(infile)) >= '0' && c <= '9') { *p++ = c; result = result * 10 + (c - '0'); lresult = lresult * 10 + (c - '0'); if (result <= MinLong || result >= MaxLong) { over = 1; /* flag overflow */ result = 0; /* reset to avoid fp exception */ } } if (c == 'r' || c == 'R') { *p++ = c; radix = result; lresult = 0; result = 0; while (c = getc(infile)) { *p++ = c; if (isdigit(c) || isalpha(c)) c = tonum(c); else break; result = result * radix + c; lresult = lresult * radix + c; if (result <= MinLong || result >= MaxLong) { over = 1; /* flag overflow */ result = 0; /* reset to avoid fp exception */ } } } nlflag = (c == '\n'); if (!over) return lresult; /* integer is small enough */ else { /* integer is too large */ *p++ = 0; *cp = putident((int)(p - lsfree));/* convert integer to string */ return -1; /* indicate integer is too big */ } } /* * getreal - get an Icon real number from infile, and return it. */double getreal() { double n; register int c, d, e; int esign; register char *s, *ep; char cbuf[128]; double atof(); s = cbuf; d = 0; while ((c = getc(infile)) == '0') ; while (c >= '0' && c <= '9') { *s++ = c; d++; c = getc(infile); } if (c == '.') { if (s == cbuf) *s++ = '0'; *s++ = c; while ((c = getc(infile)) >= '0' && c <= '9') *s++ = c; } ep = s; if (c == 'e' || c == 'E') { *s++ = c; if ((c = getc(infile)) == '+' || c == '-') { esign = (c == '-'); *s++ = c; c = getc(infile); } e = 0; while (c >= '0' && c <= '9') { e = e * 10 + c - '0'; *s++ = c; c = getc(infile); } if (esign) e = -e; e += d - 1; if (abs(e) >= LogHuge) *ep = '\0'; } *s = '\0'; n = atof(cbuf); nlflag = (c == '\n'); return n; } /* * getlab - get a label ("L" followed by a number) from infile, * and return the number. */int getlab() {ter int c; while ((c = getc(infile)) != 'L' && c != EOF && c != '\n') ; if (c == 'L') return getdec(); nlflag = (c == '\n'); return 0; } /* * getstrlit - get a string literal from infile, as a string * of octal bytes, and return it. */char *getstrlit(l)register int l; { register char *p; if (lsfree + l > lsend) quit("out of string space"); p = lsfree; while (!nlflag && l--) *p++ = getoct(); *p++ = 0; return putident((int)(p-lsfree)); } /* * newline - skip to next line. */novalue newline() { register int c; if (!nlflag) { while ((c = getc(infile)) != '\n' && c != EOF) ; } nlflag = 0; } :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:icont Folder:lmem.c
/* * lmem.c -- memory initialization and allocation; also parses arguments. */#include "::h:config.h"#include "tproto.h"#include "globals.h"#include "link.h"#include "general.h"/* * The following code is operating-system dependent [@lmem.01]. It includes * files that are system dependent. */#if PORT /* nothing is needed */Deliberate Syntax Error#endif /* PORT */#if AMIGA || ATARI_ST || HIGHC_386 || MACINTOSH || VMS /* nothing is needed */#endif /* AMIGA || ATARI_AT || HIGHC_386 ... */#if MSDOS#if MICROSOFT#include <sys/types.h>#include <sys/stat.h>#endif /* MICROSOFT */#if TURBO#include <sys/stat.h>#endif /* TURBO */#endif /* MSDOS */#if MVS || VM#include <file.h>#endif /* MVS || VM */#if OS2#if MICROSOFT#include <sys/types.h>#include <sys/stat.h>#endif /* MICROSOFT */#endif /* OS2 */#if UNIX#ifndef ATT3B#include <sys/types.h>#include <sys/stat.h>#endif /* ATT3B */#endif /* UNIX *//* * End of operating-system specific code. *//* * Prototypes. */hidden struct lfile *alclfile Params((char *name));hidden int canread Params((char *file));hidden novalue freelfile Params((struct lfile *p));hidden int trypath Params((char *name,char *file));/* * Memory initialization */struct gentry **lghash; /* hash area for global table */struct ientry **lihash; /* hash area for identifier table */struct fentry **lfhash; /* hash area for field table */struct lentry *lltable; /* local table */struct gentry *lgtable; /* global table */struct centry *lctable; /* constant table */struct ientry *litable; /* identifier table */struct fentry *lftable; /* field table headers */struct rentry *lrtable; /* field table record lists */struct ipc_fname *fnmtbl; /* table associating ipc with file name */struct ipc_line *lntable; /* table associating ipc with line number */char *lsspace; /* string space */word *labels; /* label table */char *codeb; /* generated code space */struct gentry *lgfree; /* free pointer for global table */struct ientry *lifree; /* free pointer for identifier table */struct fentry *lffree; /* free pointer for field table headers */struct rentry *lrfree; /* free pointer for field table record lists */struct ipc_fname *fnmfree; /* free pointer for ipc/file name table */struct ipc_line *lnfree; /* free pointer for ipc/line number table */char *lsfree; /* free pointer for string space */char *codep; /* free pointer for code space */char *lsend; /* pointer to end of string space */static char *ipath; /* path for iconx */#ifdef MultipleRunsextern word pc;extern int fatals;extern int nlflag;extern int lstatics;extern int nfields;#endif /* MultipleRuns *//* * linit - scan the command line arguments and initialize data structures. */novalue linit() { struct gentry **gp; struct ientry **ip; struct fentry **fp; llfiles = NULL; /* Zero queue of files to link. */#ifdef EnvVars ipath = getenv("IPATH");#else /* EnvVars */ ipath = NULL;#endif /* EnvVars */ if (ipath == NULL)/* * The following code is operating-system dependent [@lmem.02]. Set default for * IPATH. */#if PORT /* something is needed */Deliberate Syntax Error#endif /* PORT */#if AMIGA /* * There is no environment, so set ipath to the null string. The * current directory is searched anyway and there is no symbol * to force current path search. */ ipath = "";#endif /* AMIGA */#if ATARI_ST || UNIX ipath = ".";#endif /* ATARI_ST || UNIX */#if HIGHC_386 || MSDOS || OS2 ipath = ";";#endif /* HIGHC_386 || MSDOS || OS2 */#if MACINTOSH#if MPW || LSC ipath = ":";#endif /* MPW || LSC */#endif /* MACINTOSH */#if MVS || VM ipath = "";#endif /* MVS || VS */#if VMS ipath = "[]";#endif /* VMS *//* * End of operating-system specific code. */ /* * Allocate the various data structures that are used by the linker. */ lghash = (struct gentry **) tcalloc(ghsize, sizeof(struct gentry *)); lihash = (struct ientry **) tcalloc(ihsize, sizeof(struct ientry *)); lfhash = (struct fentry **) tcalloc(fhsize, sizeof(struct fentry *)); lltable = (struct lentry *) tcalloc(lsize, sizeof(struct lentry)); lctable = (struct centry *) tcalloc(csize, sizeof(struct centry)); lffree = lftable = (struct fentry *) tcalloc(fsize, sizeof(struct fentry)); lgfree = lgtable = (struct gentry *) tcalloc(gsize, sizeof(struct gentry)); lifree = litable = (struct ientry *) tcalloc(isize, sizeof(struct ientry )); lnfree = lntable = (struct ipc_line*)tcalloc(nsize,sizeof(struct ipc_line)); lrfree = lrtable = (struct rentry *) tcalloc(rsize, sizeof(struct rentry)); lsfree = lsspace = (char *) tcalloc(stsize, sizeof(char)); lsend = lsspace + stsize - 1; fnmtbl = (struct ipc_fname *) tcalloc(fnmsize, sizeof(struct ipc_fname)); fnmfree = fnmtbl; labels = (word *) tcalloc(maxlabels, sizeof(word)); codep = codeb = (char *) tcalloc(maxcode, 1); /* * Zero out the hash tables. */ for (gp = lghash; gp < &lghash[ghsize]; gp++) *gp = NULL; for (ip = lihash; ip < &lihash[ihsize]; ip++) *ip = NULL; for (fp = lfhash; fp < &lfhash[fhsize]; fp++) *fp = NULL;#ifdef MultipleRuns /* * Initializations required for repeated program runs. */ pc = 0; /* In lcode.c */ nrecords = 0; /* In lglob.c */#ifdef EvalTrace colmno = 0; /* In link.c */#endif /* EvalTrace */ lineno = 0; /* In link.c */ fatals = 0; /* In link.c */ nlflag = 0; /* In llex.c */ lstatics = 0; /* In lsym.c */ nfields = 0; /* In lsym.c */#endif /* MultipleRuns */ /* * Install "main" as a global variable in order to insure that it * is the first global variable. iconx/start.s depends on main * being global number 0. */ putglobal(instid("main"), F_Global, 0, 0); } #ifdef DeBugLinker/* * dumplfiles - print the list of files to link. Used for debugging only. */novalue dumplfiles() { struct lfile *p,*lfls; fprintf(stderr,"lfiles:\n"); lfls = llfiles; while (p = getlfile(&lfls)) fprintf("stderr,'%s'\n",p->lf_name); fflush(stderr); }#endif /* DeBugLinker */ /* * alsolink - create an lfile structure for the named file and add it to the * end of the list of files (llfiles) to generate link instructions for. */static char *pptr;novalue alsolink(name)char *name; { struct lfile *nlf, *p; char file[256], ok; ok = 0; if (canread(name)) { ok++; strcpy(file, name); } else { /* * Can't find name in current directory so try paths in * ipath if there are any. (ipath cannot override the * current directory first strategy so there is probably * no reason to initialize ipath to the various current * directory markers as is done above, since this will * only result in a duplicate failed search. Note that * the access test which is done above in some systems * will have already caused ilink to exit if name is * not found in the current directory anyway so ipath * was never able to search other paths first in any case.) */ pptr = ipath; while (trypath(name, file)) { if (canread(file)) { ok++; break; } } } if (!ok) quitf("cannot resolve reference to file '%s'",name); nlf = alclfile(file); if (llfiles == NULL) { llfiles = nlf; } else { p = llfiles; while (p->lf_link != NULL) { if (strcmp(p->lf_name,file) == 0) return; p = p->lf_link; } if (strcmp(p->lf_name,file) == 0) return; p->lf_link = nlf; } } /* * getlfile - return a pointer (p) to the lfile structure pointed at by lptr * and move lptr to the lfile structure that p points at. That is, getlfile * returns a pointer to the current (wrt. lptr) lfile and advances lptr. */struct lfile *getlfile(lptr)struct lfile **lptr; { struct lfile *p; if (*lptr == NULL) return (struct lfile *)NULL; else { p = *lptr; *lptr = p->lf_link; return p; } } /* * canread - see if file can be read and be sure that it's just an * ordinary file. */static int canread(file)char *file; {/* * The following code is operating-system dependent [@lmem.03]. Check to see if * .u1 file can be read. */#if PORT /* something is needed */Deliberate Syntax Error#endif /* PORT */#if AMIGA char lclname[MaxFileName]; if (access(makename(lclname,TargetDir,file,U1Suffix),4) == 0) if (getfa(lclname) == -1) return 1;#endif /* AMIGA */#if ATARI_ST || HIGHC_386 { FILE *f; char lclname[MaxFileName]; if ((f = fopen(makename(lclname,TargetDir,file,U1Suffix), "r")) == NULL) return 0; else { fclose(f); return 1; } }#endif /* ATARI_ST || HIGHC_386 */#if MACINTOSH#if MPW || LSC { FILE *f; if ((f = fopen(file,"r")) != NULL) { fclose(f); return 1; } }#endif /* MPW || LSC */#endif /* MACINTOSH */#if MSDOS#if MICROSOFT || TURBO struct stat statb; if (access(file,4) == 0) { stat(file,&statb); if (statb.st_mode & S_IFREG) return 1; }#else /* MICROSOFT || TURBO */ char lclname[MaxFileName]; if (access( makename(lclname,TargetDir,file,U1Suffix), 4 ) == 0 ) return 1;#endif /* MICROSOFT || TURBO */#endif /* MSDOS */#if MVS || VM FILE *f; /* can't use access because it will */ /* accept LRECL, etc. */ if ((f = fopen(file,"r")) != NULL { fclose(f); return 1; }#endif /* MVS || VM */#if OS2#if MICROSOFT struct stat statb; if (access(file,4) == 0) { stat(file,&statb); if (statb.st_mode & S_IFREG) return 1; }#endif /* MICROSOFT || TURBO */#endif /* OS2 */#if UNIX struct stat statb; if (access(file,4) == 0) { stat(file,&statb); if (statb.st_mode & S_IFREG) return 1; }#endif /* UNIX */#if VMS char lclname[MaxFileName]; if (access(makename(lclname,TargetDir,file,U1Suffix),4) == 0) return 1;#endif /* VMS *//* * End of operating-system specific code. */ return 0; } /* * trypath - form a file name in file by concatenating name onto the * next path element. */static int trypath(name,file)char *name, *file; { char c; while (*pptr == ' ') pptr++; if (!*pptr) return 0; do { c = (*file++ = *pptr++); } while (c != ' ' && c); pptr--; file--;/* * The following code is operating-system dependent [@lmem.04]. Append path * character. */#if PORT /* nothing is needed */Deliberate Syntax Error#endif /* PORT */#if AMIGA file--; switch (*file) { case ':': case '/': file++; break; /* add nothing, delimiter already there */ default: *file++ = '/'; }#endif /* AMIGA */#if ATARI_ST || MACINTOSH || MVS || VM || VMS /* nothing is needed */#endif /* ATARI_ST || MACINTOSH */#if HIGHC_386 *file++ = '\\';#endif /* HIGHC_386 */#if UNIX || MSDOS || OS2 *file++ = '/'; /* should check for delimiter */#endif /* UNIX || MSDOS || OS2 *//* * End of operating-system specific code. */ while (*file++ = *name++); *file = 0; return 1; } /* * alclfile - allocate an lfile structure for the named file, fill * in the name and return a pointer to it. */static struct lfile *alclfile(name)char *name; { struct lfile *p; p = (struct lfile *) alloc(sizeof(struct lfile)); p->lf_link = NULL; p->lf_name = salloc(name); return p; } #ifdef MultipleRuns/* * freelfile - free memory of an lfile structure. */static novalue freelfile(p)struct lfile *p; { free(p->lf_name); free((char *) p); }#endif /* MultipleRuns */ /* * lmfree - free memory used by the linker */novalue lmfree() { struct lfile *lf, *nlf; free((char *) lghash); lghash = NULL; free((char *) lihash); lihash = NULL; free((char *) lfhash); lfhash = NULL; free((char *) lltable); lltable = NULL; free((char *) lctable); lctable = NULL; free((char *) lftable); lftable = NULL; free((char *) lgtable); lgtable = NULL; free((char *) litable); litable = NULL; free((char *) lntable); lntable = NULL; free((char *) lrtable); lrtable = NULL; free((char *) lsspace); lsspace = NULL; free((char *) fnmtbl); fnmtbl = NULL; free((char *) labels); labels = NULL; free((char *) codep); codep = NULL;#ifdef MultipleRuns for (lf = llfiles; lf != NULL; lf = nlf) { nlf = lf->lf_link; freelfile(lf); } llfiles = NULL;#if MACINTOSH#if MPW/* #pragma unused(nlf,lf) */#endif /* MPW */#endif /* MACINTOSH */#endif /* MultipleRuns */ } :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:icont Folder:lnklist.c
/* * lnklist.c -- functions for handling file linking. */#include "::h:config.h"#include "tproto.h"#include "trans.h"#include "lfile.h"/* * Prototype. */struct lfile *alclfile Params((char *name));struct lfile *lfiles;/* * Dummy function to satify restriction on the length of the name of * the first function in a file ... on a certain system. Needs to * be handled in a better fashion. */novalue dummyda() { }/* * alclfile allocates an lfile structure for the named file, fills * in the name and returns a pointer to it. */static struct lfile *alclfile(name)char *name; { struct lfile *p; p = (struct lfile *) alloc(sizeof(struct lfile)); if (!p) tsyserr("not enough memory for file list"); p->lf_link = NULL; p->lf_name = salloc(name); return p; } /* * addlfile creates an lfile structure for the named file and add it to the * end of the list of files (lfiles) to generate link instructions for. */novalue addlfile(name)char *name;{ struct lfile *nlf, *p; nlf = alclfile(name); if (lfiles == NULL) { lfiles = nlf; } else { p = lfiles; while (p->lf_link != NULL) { p = p->lf_link; } p->lf_link = nlf; }} :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:icont Folder:lsym.c
/* * lsym.c -- functions for symbol table manipulation. */#include "::h:config.h"#include "tproto.h"#include "globals.h"#include "link.h"#include "general.h"/* * Prototypes. */hidden struct fentry *alcfhead Params((struct fentry *blink,char *name, int fid, struct rentry *rlist));hidden struct rentry *alcfrec Params((struct rentry *link,int rnum, int fnum));hidden struct tgentry *alcglob Params((struct tgentry *blink, char *name, int flag,int nargs));hidden struct gentry *alcglobal Params((struct gentry *blink,char *name, int flag,int nargs,int procid));hidden struct ientry *alcident Params((char *nam,int len));int dynoff; /* stack offset counter for locals */int argoff; /* stack offset counter for arguments */int static1; /* first static in procedure */int lstatics = 0; /* static variable counter */int nlocal; /* number of locals in local table */int nconst; /* number of constants in constant table */int nfields = 0; /* number of fields in field table *//* * instid - copy the string s to the start of the string free space * and call putident with the length of the string. */char *instid(s)char *s; { register int l; register char *p1, *p2; p1 = lsfree; p2 = s; l = 0; do { if (p1 > lsend) quit("out of string space"); l++; } while (*p1++ = *p2++); return putident(l); } /* * putident - install the identifier named by the string starting at lsfree * and extending for len bytes. The installation entails making an * entry in the identifier hash table and then making an identifier * table entry for it with alcident. A side effect of installation * is the incrementing of lsfree by the length of the string, thus * "saving" it. * * Nothing is changed if the identifier has already been installed. */char *putident(len)int len; { register int hash; register char *s; register struct ientry *ip; int l; /* * Compute hash value by adding bytes and masking result with imask. * (Recall that imask is ihsize-1.) */ s = lsfree; hash = 0; l = len; while (l--) hash += *s++; l = len; s = lsfree; hash &= imask; /* * If the identifier hasn't been installed, install it. */ if ((ip = lihash[hash]) != NULL) { /* collision */ for (;;) { /* work down i_blink chain until id is found or the end of the chain is reached */ if (l == ip->i_length && lexeql(l, s, ip->i_name)) return (ip->i_name); /* id is already installed, return it */ if (ip->i_blink == NULL) { /* end of chain */ ip->i_blink = alcident(s, l); lsfree += l; return s; } ip = ip->i_blink; } } /* * Hashed to an empty slot. */ lihash[hash] = alcident(s, l); lsfree += l; return s; } /* * lexeql - compare two strings of given length. Returns non-zero if * equal, zero if not equal. */int lexeql(l, s1, s2)register int l;register char *s1, *s2; { while (l--) if (*s1++ != *s2++) return 0; return 1; } /* * alcident - get the next free identifier table entry, and fill it in with * the specified values. */static struct ientry *alcident(nam, len)char *nam;int len; { register struct ientry *ip; if (lifree >= &litable[isize]) quit("out of identifier table space"); ip = lifree++; ip->i_blink = NULL; ip->i_name = nam; ip->i_length = len; return ip; } /* * locinit - clear local symbol table. */novalue locinit() { dynoff = 0; argoff = 0; nlocal = -1; nconst = -1; static1 = lstatics; } /* * putlocal - make a local symbol table entry. */novalue putlocal(n, id, flags, imperror, procname)int n;char *id;register int flags;int imperror;char *procname; { register struct lentry *lp; union { struct gentry *gp; int bn; } p; if (n >= lsize) quit("out of local symbol table space"); if (n > nlocal) nlocal = n; lp = &lltable[n]; lp->l_name = id; lp->l_flag = flags; if (flags == 0) { /* undeclared */ if ((p.gp = glocate(id)) != NULL) { /* check global */ lp->l_flag = F_Global; lp->l_val.global = p.gp; } else if ((p.bn = blocate(id)) != 0) { /* check for function */ lp->l_flag = F_Builtin; lp->l_val.global = putglobal(id, F_Builtin | F_Proc, -1, p.bn); } else { /* implicit local */ if (imperror) lwarn(id, "undeclared identifier, procedure ", procname); lp->l_flag = F_Dynamic; lp->l_val.offset = ++dynoff; } } else if (flags & F_Global) { /* global variable */ if ((p.gp = glocate(id)) == NULL) quit("putlocal: global not in global table"); lp->l_val.global = p.gp; } else if (flags & F_Argument) /* procedure argument */ lp->l_val.offset = ++argoff; else if (flags & F_Dynamic) /* local dynamic */ lp->l_val.offset = ++dynoff; else if (flags & F_Static) /* local static */ lp->l_val.staticid = ++lstatics; else quit("putlocal: unknown flags"); } /* * putglobal - make a global symbol table entry. */struct gentry *putglobal(id, flags, nargs, procid)char *id;int flags;int nargs;int procid; { register struct gentry *p; if ((p = glocate(id)) == NULL) { /* add to head of hash chain */ p = lghash[ghasher(id)]; lghash[ghasher(id)] = alcglobal(p, id, flags, nargs, procid); return lghash[ghasher(id)]; } p->g_flag |= flags; p->g_nargs = nargs; p->g_procid = procid; return p; } /* * putconst - make a constant symbol table entry. */novalue putconst(n, flags, len, pc, valp)int n;int flags, len;word pc;union xval *valp; { register struct centry *p; if (n >= csize) quit("out of constant table space"); if (nconst < n) nconst = n; p = &lctable[n]; p->c_flag = flags; p->c_pc = pc; if (flags & F_IntLit) { p->c_val.ival = valp->ival; } else if (flags & F_StrLit) { p->c_val.sval = valp->sval; p->c_length = len; } else if (flags & F_CsetLit) { p->c_val.sval = valp->sval; p->c_length = len; } else if (flags & F_RealLit)#ifdef Double/* access real values one word at a time */ { int *rp, *rq; rp = (int *) &(p->c_val.rval); rq = (int *) &(valp->rval); *rp++ = *rq++; *rp = *rq; }#else /* Double */ p->c_val.rval = valp->rval;#endif /* Double */ else fprintf(stderr, "putconst: bad flags: %06o %011lo\n", flags, valp->ival); } /* * putfield - make a record/field table entry. */novalue putfield(fname, rnum, fnum)char *fname;int rnum, fnum; { register struct fentry *fp; register struct rentry *rp, *rp2; word hash; fp = flocate(fname); if (fp == NULL) { /* create a field entry */ nfields++; hash = fhasher(fname); fp = lfhash[hash]; lfhash[hash] = alcfhead(fp, fname, nfields, alcfrec((struct rentry *)NULL, rnum, fnum)); return; } rp = fp->f_rlist; /* found field entry, look for */ if (rp->r_recid > rnum) { /* spot in record list */ fp->f_rlist = alcfrec(rp, rnum, fnum); return; } while (rp->r_recid < rnum) { /* keep record list ascending */ if (rp->r_link == NULL) { rp->r_link = alcfrec((struct rentry *)NULL, rnum, fnum); return; } rp2 = rp; rp = rp->r_link; } rp2->r_link = alcfrec(rp, rnum, fnum); } /* * glocate - lookup identifier in global symbol table, return NULL * if not present. */struct gentry *glocate(id)char *id; { register struct gentry *p; p = lghash[ghasher(id)]; while (p != NULL && p->g_name != id) p = p->g_blink; return p; } /* * flocate - lookup identifier in field table. */struct fentry *flocate(id)char *id; { register struct fentry *p; p = lfhash[fhasher(id)]; while (p != NULL && p->f_name != id) p = p->f_blink; return p; } /* * alcglobal - create a new global symbol table entry. */static struct gentry *alcglobal(blink, name, flag, nargs, procid)struct gentry *blink;char *name;int flag;int nargs;int procid; { register struct gentry *gp; if (lgfree >= &lgtable[gsize]) quit("out of global symbol table space"); gp = lgfree++; gp->g_blink = blink; gp->g_name = name; gp->g_flag = flag; gp->g_nargs = nargs; gp->g_procid = procid; return gp; } /* * alcfhead - allocate a field table header. */static struct fentry *alcfhead(blink, name, fid, rlist)struct fentry *blink;char *name;int fid;struct rentry *rlist; { register struct fentry *fp; if (lffree >= &lftable[fsize]) quit("out of field table space"); fp = lffree++; fp->f_blink = blink; fp->f_name = name; fp->f_fid = fid; fp->f_rlist = rlist; return fp; } /* * alcfrec - allocate a field table record list element. */static struct rentry *alcfrec(link, rnum, fnum)struct rentry *link;int rnum, fnum; { register struct rentry *rp; if (lrfree >= &lrtable[rsize]) quit("out of field table space for record lists"); rp = lrfree++; rp->r_link = link; rp->r_recid = rnum; rp->r_fnum = fnum; return rp; } /* * blocate - search for a function. The search is linear to make * it easier to add/delete functions. If found, returns index+1 for entry. */int blocate(s)register char *s; { register int i; extern char *ftable[]; extern int ftbsize; for (i = 0; i < ftbsize; i++) if (strcmp(ftable[i], s) == 0) return i + 1; return 0; } :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:icont Folder:Makefile
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:icont Folder:parse.
+++++ Continued from previous card +++++
state */ if( yychar<0 ) if( (yychar=yylex())<0 ) yychar=0; if( (yyn += yychar)<0 || yyn >= YYLAST ) goto yydefault; if( yychk[ yyn=yyact[ yyn ] ] == yychar ){ /* valid shift */ yychar = -1; yyval = yylval; yystate = yyn; if( yyerrflag > 0 ) --yyerrflag; goto yystack; } yydefault: /* default state action */ if( (yyn=yydef[yystate]) == -2 ) { if( yychar<0 ) if( (yychar=yylex())<0 ) yychar = 0; /* look through exception table */ for( yyxi=yyexca; (*yyxi!= (-1)) || (yyxi[1]!=yystate) ; yyxi += 2 ) ; /* VOID */ while( *(yyxi+=2) >= 0 ){ if( *yyxi == yychar ) break; } if( (yyn = yyxi[1]) < 0 ) return(0); /* accept */ } if( yyn == 0 ){ /* error */ /* error ... attempt to resume parsing */ switch( yyerrflag ){ case 0: /* brand new error */ yyerror( yychar, yylval, yystate ); yyerrlab: ++yynerrs; case 1: case 2: /* incompletely recovered error ... try again */ yyerrflag = 3; /* find a state where "error" is a legal shift action */ while ( yyps >= yys ) { yyn = yypact[*yyps] + YYERRCODE; if( yyn>= 0 && yyn < YYLAST && yychk[yyact[yyn]] == YYERRCODE ){ yystate = yyact[yyn]; /* simulate a shift of "error" */ goto yystack; } yyn = yypact[*yyps]; /* the current yyps has no shift onn "error", pop stack */#ifdef YYDEBUG if( yydebug ) printf( "error recovery pops state %d, uncovers %d\n", *yyps, yyps[-1] );#endif --yyps; --yypv; } /* there is no state on the stack with an error shift ... abort */ yyabort: return(1); case 3: /* no shift yet; clobber input char */#ifdef YYDEBUG if( yydebug ) printf( "error recovery discards char %d\n", yychar );#endif if( yychar == 0 ) goto yyabort; /* don't discard EOF, quit */ yychar = -1; goto yynewstate; /* try again in the same state */ } } /* reduction by production yyn */#ifdef YYDEBUG if( yydebug ) printf("reduce %d\n",yyn);#endif yyps -= yyr2[yyn]; yypvt = yypv; yypv -= yyr2[yyn]; yyval = yypv[1]; yym=yyn; /* consult goto table to find next state */ yyn = yyr1[yyn]; yyj = yypgo[yyn] + *yyps + 1; if( yyj>=YYLAST || yychk[ yystate = yyact[yyj] ] != -yyn ) yystate = yyact[yypgo[yyn]]; switch(yym){ case 1:# line 161 "expanded.g"{gout(globfile);} break;case 4:# line 166 "expanded.g"{if (!nocode) rout(globfile, Str0(yypvt[-0])); nocode = 0; loc_init();} break;case 5:# line 170 "expanded.g"{if (!nocode) codegen(yypvt[-0]); nocode = 0; treeinit(); loc_init();} break;case 6:# line 175 "expanded.g"{;} break;case 7:# line 176 "expanded.g"{;} break;case 8:# line 178 "expanded.g"{;} break;case 10:# line 181 "expanded.g"{;} break;case 11:# line 183 "expanded.g"{addlfile(Str0(yypvt[-0]));} break;case 12:# line 184 "expanded.g"{addlfile(Str0(yypvt[-0]));} break;case 13:# line 186 "expanded.g"{idflag = F_Global;} break;case 14:# line 186 "expanded.g"{;} break;case 15:# line 188 "expanded.g"{idflag = F_Argument;} break;case 16:# line 188 "expanded.g"{ install(Str0(yypvt[-3]),F_Record|F_Global,id_cnt); yyval = yypvt[-3]; } break;case 17:# line 193 "expanded.g"{id_cnt = 0;} break;case 18:# line 194 "expanded.g"{;} break;case 19:# line 196 "expanded.g"{ yyval = tree6(N_Proc,yypvt[-5],yypvt[-5],yypvt[-2],yypvt[-1],yypvt[-0]); } break;case 20:# line 200 "expanded.g"{idflag = F_Argument;} break;case 21:# line 200 "expanded.g"{ yyval = yypvt[-3]; install(Str0(yypvt[-3]),F_Proc|F_Global,id_cnt); } break;case 22:# line 205 "expanded.g"{id_cnt = 0;} break;case 23:# line 206 "expanded.g"{;} break;case 24:# line 207 "expanded.g"{id_cnt = -id_cnt;} break;case 25:# line 210 "expanded.g"{ install(Str0(yypvt[-0]),idflag,0); id_cnt = 1; } break;case 26:# line 214 "expanded.g"{ install(Str0(yypvt[-0]),idflag,0); ++id_cnt; } break;case 27:# line 219 "expanded.g"{;} break;case 28:# line 220 "expanded.g"{;} break;case 29:# line 222 "expanded.g"{idflag = F_Dynamic;} break;case 30:# line 223 "expanded.g"{idflag = F_Static;} break;case 31:# line 225 "expanded.g"{yyval = tree1(N_Empty) ;} break;case 32:# line 226 "expanded.g"{yyval = yypvt[-1];} break;case 33:# line 228 "expanded.g"{yyval = tree1(N_Empty) ;} break;case 34:# line 229 "expanded.g"{yyval = tree4(N_Slist,yypvt[-1],yypvt[-2],yypvt[-0]) ;} break;case 35:# line 231 "expanded.g"{yyval = tree1(N_Empty) ;} break;case 38:# line 235 "expanded.g"{yyval = tree5(N_Conj,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]) ;} break;case 40:# line 238 "expanded.g"{yyval = tree5(N_Scan,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]) ;} break;case 42:# line 241 "expanded.g"case 43:# line 242 "expanded.g"case 44:# line 243 "expanded.g"case 45:# line 244 "expanded.g"{yyval = tree5(N_Binop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;case 46:# line 245 "expanded.g"{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;case 47:# line 246 "expanded.g"{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;case 48:# line 247 "expanded.g"{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;case 49:# line 248 "expanded.g"{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;case 50:# line 249 "expanded.g"{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;case 51:# line 250 "expanded.g"{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;case 52:# line 251 "expanded.g"{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;case 53:# line 252 "expanded.g"{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;case 54:# line 253 "expanded.g"{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;case 55:# line 254 "expanded.g"{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;case 56:# line 255 "expanded.g"{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;case 57:# line 256 "expanded.g"{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;case 58:# line 257 "expanded.g"{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;case 59:# line 258 "expanded.g"{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;case 60:# line 259 "expanded.g"{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;case 61:# line 260 "expanded.g"{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;case 62:# line 261 "expanded.g"{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;case 63:# line 262 "expanded.g"{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;case 64:# line 263 "expanded.g"{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;case 65:# line 264 "expanded.g"{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;case 66:# line 265 "expanded.g"{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;case 67:# line 266 "expanded.g"{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;case 68:# line 267 "expanded.g"{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;case 69:# line 268 "expanded.g"{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;case 70:# line 269 "expanded.g"{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;case 71:# line 270 "expanded.g"{yyval = tree5(N_Scan,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]) ;} break;case 72:# line 271 "expanded.g"{yyval = tree5(N_Conj,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]) ;} break;case 73:# line 272 "expanded.g"{yyval = tree5(N_Activat,yypvt[-1],yypvt[-1],yypvt[-0],yypvt[-2]) ;} break;case 75:# line 275 "expanded.g"{yyval = tree4(N_To,yypvt[-1],yypvt[-2],yypvt[-0]) ;} break;case 76:# line 276 "expanded.g"{yyval = tree5(N_ToBy,yypvt[-3],yypvt[-4],yypvt[-2],yypvt[-0]) ;} break;case 78:# line 279 "expanded.g"{yyval = tree4(N_Alt,yypvt[-1],yypvt[-2],yypvt[-0]) ;} break;case 80:# line 282 "expanded.g"case 81:# line 283 "expanded.g"case 82:# line 284 "expanded.g"case 83:# line 285 "expanded.g"case 84:# line 286 "expanded.g"case 85:# line 287 "expanded.g"case 86:# line 288 "expanded.g"case 87:# line 289 "expanded.g"case 88:# line 290 "expanded.g"case 89:# line 291 "expanded.g"case 90:# line 292 "expanded.g"case 91:# line 293 "expanded.g"case 92:# line 294 "expanded.g"case 93:# line 295 "expanded.g"case 95:# line 298 "expanded.g"case 96:# line 299 "expanded.g"case 98:# line 302 "expanded.g"case 99:# line 303 "expanded.g"case 100:# line 304 "expanded.g"case 101:# line 305 "expanded.g"case 103:# line 308 "expanded.g"case 104:# line 309 "expanded.g"case 105:# line 310 "expanded.g"case 106:# line 311 "expanded.g"case 108:# line 314 "expanded.g"{yyval = tree5(N_Binop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;case 110:# line 317 "expanded.g"{yyval = tree4(N_Limit,yypvt[-2],yypvt[-2],yypvt[-0]) ;} break;case 111:# line 318 "expanded.g"{yyval = tree5(N_Activat,yypvt[-1],yypvt[-1],yypvt[-0],yypvt[-2]) ;} break;case 112:# line 319 "expanded.g"{yyval = tree4(N_Apply,yypvt[-1],yypvt[-2],yypvt[-0]) ;} break;case 114:# line 322 "expanded.g"{yyval = tree5(N_Activat,yypvt[-1],yypvt[-1],yypvt[-0],tree1(N_Empty) ) ;} break;case 115:# line 323 "expanded.g"{yyval = tree3(N_Not,yypvt[-0],yypvt[-0]) ;} break;case 116:# line 324 "expanded.g"{yyval = tree3(N_Bar,yypvt[-0],yypvt[-0]) ;} break;case 117:# line 325 "expanded.g"{yyval = tree3(N_Bar,yypvt[-0],yypvt[-0]) ;} break;case 118:# line 326 "expanded.g"{yyval = tree3(N_Bar,yypvt[-0],yypvt[-0]) ;} break;case 119:# line 327 "expanded.g"{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break;case 120:# line 328 "expanded.g"{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break;case 121:# line 329 "expanded.g"{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break;case 122:# line 330 "expanded.g"{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break;case 123:# line 331 "expanded.g"{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break;case 124:# line 332 "expanded.g"{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break;case 125:# line 333 "expanded.g"{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break;case 126:# line 334 "expanded.g"{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break;case 127:# line 335 "expanded.g"{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break;case 128:# line 336 "expanded.g"{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break;case 129:# line 337 "expanded.g"{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break;case 130:# line 338 "expanded.g"{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break;case 131:# line 339 "expanded.g"{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break;case 132:# line 340 "expanded.g"{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break;case 133:# line 341 "expanded.g"{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break;case 134:# line 342 "expanded.g"{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break;case 135:# line 343 "expanded.g"{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break;case 136:# line 344 "expanded.g"{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break;case 137:# line 345 "expanded.g"{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break;case 147:# line 355 "expanded.g"{yyval = tree3(N_Create,yypvt[-1],yypvt[-0]) ;} break;case 148:# line 356 "expanded.g"{Val0(yypvt[-0]) = putloc(Str0(yypvt[-0]),0);} break;case 149:# line 357 "expanded.g"{yyval = tree2(N_Next,yypvt[-0]) ;} break;case 150:# line 358 "expanded.g"{yyval = tree3(N_Break,yypvt[-1],yypvt[-0]) ;} break;case 151:# line 359 "expanded.g"{if ((yypvt[-1])->n_type st) yyval = tree4(N_Invok,yypvt[-2],tree1(N_Empty) ,yypvt[-1]); else yyval = yypvt[-1];} break;case 152:# line 363 "expanded.g"{yyval = yypvt[-1];} break;case 153:# line 364 "expanded.g"{yyval = tree3(N_List,yypvt[-2],yypvt[-1]) ;} break;case 154:# line 365 "expanded.g"{yyval = tree5(N_Binop,yypvt[-2],yypvt[-2],yypvt[-3],yypvt[-1]);} break;case 155:# line 366 "expanded.g"{yyval = tree4(N_Invok,yypvt[-1],yypvt[-2], tree3(N_List,yypvt[-1],tree1(N_Empty) )) ;} break;case 156:# line 368 "expanded.g"{yyval = tree4(N_Invok,yypvt[-2],yypvt[-3],tree3(N_List,yypvt[-2],yypvt[-1])) ;} break;case 157:# line 370 "expanded.g"{yyval = tree4(N_Invok,yypvt[-2],yypvt[-3],yypvt[-1]) ;} break;case 158:# line 371 "expanded.g"{yyval = tree4(N_Field,yypvt[-1],yypvt[-2],yypvt[-0]) ;} break;case 159:# line 372 "expanded.g"{yyval = int_leaf(N_Key,yypvt[-1],K_FAIL) ;} break;case 160:# line 373 "expanded.g"{if ((key_num = klookup(Str0(yypvt[-0]))) == 0) tfatal("invalid keyword",Str0(yypvt[-0])); yyval = int_leaf(N_Key,yypvt[-1],key_num);} break;case 161:# line 377 "expanded.g"{yyval = tree5(N_Loop,yypvt[-1],yypvt[-1],yypvt[-0],tree1(N_Empty) );} break;case 162:# line 378 "expanded.g"{yyval = tree5(N_Loop,yypvt[-3],yypvt[-3],yypvt[-2],yypvt[-0]) ;} break;case 163:# line 380 "expanded.g"{yyval = tree5(N_Loop,yypvt[-1],yypvt[-1],yypvt[-0],tree1(N_Empty) ) ;} break;case 164:# line 381 "expanded.g"{yyval = tree5(N_Loop,yypvt[-3],yypvt[-3],yypvt[-2],yypvt[-0]) ;} break;case 165:# line 383 "expanded.g"{yyval = tree5(N_Loop,yypvt[-1],yypvt[-1],yypvt[-0],tree1(N_Empty) ) ;} break;case 166:# line 384 "expanded.g"{yyval = tree5(N_Loop,yypvt[-3],yypvt[-3],yypvt[-2],yypvt[-0]) ;} break;case 167:# line 386 "expanded.g"{yyval = tree5(N_Loop,yypvt[-1],yypvt[-1],yypvt[-0],tree1(N_Empty) ) ;} break;case 168:# line 388 "expanded.g"{yyval = tree4(N_Ret,yypvt[-0],yypvt[-0],tree1(N_Empty) ) ;} break;case 169:# line 389 "expanded.g"{yyval = tree4(N_Ret,yypvt[-1],yypvt[-1],yypvt[-0]) ;} break;case 170:# line 390 "expanded.g"{yyval = tree5(N_Loop,yypvt[-1],yypvt[-1],yypvt[-0],tree1(N_Empty) ) ;} break;case 171:# line 391 "expanded.g"{yyval = tree5(N_Loop,yypvt[-3],yypvt[-3],yypvt[-2],yypvt[-0]) ;} break;case 172:# line 393 "expanded.g"{yyval = tree5(N_If,yypvt[-3],yypvt[-2],yypvt[-0],tree1(N_Empty) ) ;} break;case 173:# line 394 "expanded.g"{yyval = tree5(N_If,yypvt[-5],yypvt[-4],yypvt[-2],yypvt[-0]) ;} break;case 174:# line 396 "expanded.g"{yyval = tree4(N_Case,yypvt[-5],yypvt[-4],yypvt[-1]) ;} break;case 176:# line 399 "expanded.g"{yyval = tree4(N_Clist,yypvt[-1],yypvt[-2],yypvt[-0]) ;} break;case 177:# line 401 "expanded.g"{yyval = tree4(N_Ccls,yypvt[-1],yypvt[-2],yypvt[-0]) ;} break;case 178:# line 402 "expanded.g"{yyval = tree4(N_Ccls,yypvt[-1],yypvt[-2],yypvt[-0]) ;} break;case 180:# line 405 "expanded.g"{yyval = tree4(N_Elist,yypvt[-1],yypvt[-2],yypvt[-0]);} break;case 181:# line 407 "expanded.g"{ yyval = tree3(N_Create,yypvt[-0],yypvt[-0]) ; } break;case 182:# line 410 "expanded.g"{ yyval = tree4(N_Elist,yypvt[-1],yypvt[-2],tree3(N_Create,yypvt[-1],yypvt[-0])); } break;case 183:# line 414 "expanded.g"{Val0(yypvt[-0]) = putlit(Str0(yypvt[-0]),F_IntLit,0);} break;case 184:# line 415 "expanded.g"{Val0(yypvt[-0]) = putlit(Str0(yypvt[-0]),F_RealLit,0);} break;case 185:# line 416 "expanded.g"{Val0(yypvt[-0]) = putlit(Str0(yypvt[-0]),F_StrLit,(int)Val1(yypvt[-0]));} break;case 186:# line 417 "expanded.g"{Val0(yypvt[-0]) = putlit(Str0(yypvt[-0]),F_CsetLit,(int)Val1(yypvt[-0]));} break;case 187:# line 419 "expanded.g"{yyval = tree6(N_Sect,yypvt[-2],yypvt[-2],yypvt[-5],yypvt[-3],yypvt[-1]) ;} break;case 188:# line 421 "expanded.g"{y
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:icont Folder:parse.
+++++ Continued from previous card +++++
yval = yypvt[-0];} break;case 189:# line 422 "expanded.g"{yyval = yypvt[-0];} break;case 190:# line 423 "expanded.g"{yyval = yypvt[-0];} break;case 192:# line 426 "expanded.g"{yyval = tree4(N_Slist,yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; } goto yystack; /* stack new state and value */ } :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:icont Folder:sizes.h
/* * Definitions of sizes changeable by command option. * The size macro is defined as needed by the caller. * Parameters are: command option, variable name, default size. */Size("c", csize, 100) /* constant table */Size("f", fsize, 100) /* field table headers */Size("g", gsize, 200) /* global table */Size("i", isize, 500) /* identifier table */Size("l", lsize, 100) /* local table */Size("n", nsize, 1000) /* ipc/line num. assoc. table */Size("r", rsize, 100) /* field table record list */Size("s", stsize, 20000) /* string space */Size("t", tsize, 15000) /* parse tree space */Size("C", maxcode, 15000) /* code space per procedure */Size("F", fnmsize, 10) /* ipc/file name assoc. table */Size("L", maxlabels, 500) /* maximum number of labels/proc */Size("hc", chsize, 128) /* constant hash table */Size("hf", fhsize, 32) /* field hash table */Size("hg", ghsize, 128) /* global hash table */Size("hi", ihsize, 128) /* identifier hash table */Size("hl", lhsize, 128) /* local hash table *//* * Minimum regions sizes. */MinSize("c", csize, 10) /* constant table */MinSize("f", fsize, 10) /* field table headers */MinSize("g", gsize, 20) /* global table */MinSize("i", isize, 50) /* identifier table */MinSize("l", lsize, 10) /* local table */MinSize("n", nsize, 100) /* ipc/line num. assoc. table */MinSize("r", rsize, 10) /* field table record list */MinSize("s", stsize, 2000) /* string space */MinSize("t", tsize, 5000) /* parse tree space */MinSize("C", maxcode, 5000) /* code space per procedure */MinSize("F", fnmsize, 5) /* ipc/file name assoc. table */MinSize("L", maxlabels, 100) /* maximum number of labels/proc */MinSize("hc", chsize, 128) /* constant hash table */MinSize("hf", fhsize, 32) /* field hash table */MinSize("hg", ghsize, 128) /* global hash table */MinSize("hi", ihsize, 128) /* identifier hash table */MinSize("hl", lhsize, 128) /* local hash table */ :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:icont Folder:tcode.c
/* * tcode.c -- translator functions for traversing parse trees and generating * code. */#include "::h:config.h"#include "tproto.h"#include "globals.h"#include "trans.h"#include "token.h"#include "tree.h"#include "tsym.h"/* * Prototypes. */hidden int alclab Params((int n));hidden novalue binop Params((int op));hidden novalue emit Params((char *s));hidden novalue emitl Params((char *s,int a));hidden novalue emitlab Params((int l));hidden novalue emitn Params((char *s,int a));hidden novalue emits Params((char *s,char *a));hidden novalue setloc Params((nodeptr n));hidden int traverse Params((nodeptr t));hidden novalue unopa Params((int op, nodeptr t));hidden novalue unopb Params((int op));extern int tfatals;extern int nocode;extern char *comfile;/* * Code generator parameters. */#define LoopDepth 20 /* max. depth of nested loops */#define CaseDepth 10 /* max. depth of nested case statements */#define CreatDepth 10 /* max. depth of nested create statements *//* * loopstk structures hold information about nested loops. */struct loopstk { int nextlab; /* label for next exit */ int breaklab; /* label for break exit */ int markcount; /* number of marks */ int ltype; /* loop type */ };/* * casestk structure hold information about case statements. */struct casestk { int endlab; /* label for exit from case statement */ nodeptr deftree; /* pointer to tree for default clause */ };/* * creatstk structures hold information about create statements. */struct creatstk { int nextlab; /* previous value of nextlab */ int breaklab; /* previous value of breaklab */ };static int nextlab; /* next label allocated by alclab() */ /* * codegen - traverse tree t, generating code. */novalue codegen(t)nodeptr t; { nextlab = 1; traverse(t); } /* * traverse - traverse tree rooted at t and generate code. This is just * plug and chug code for each of the node types. */static int traverse(t)register nodeptr t; { register int lab, n, i; struct loopstk loopsave; static struct loopstk loopstk[LoopDepth]; /* loop stack */ static struct loopstk *loopsp; static struct casestk casestk[CaseDepth]; /* case stack */ static struct casestk *casesp; static struct creatstk creatstk[CreatDepth]; /* create stack */ static struct creatstk *creatsp; n = 1; switch (TType(t)) { case N_Activat: /* co-expression activation */ if (Val0(Tree0(t)) == AUGACT) { emit("pnull"); } traverse(Tree2(t)); /* evaluate result expression */ if (Val0(Tree0(t)) == AUGACT) emit("sdup"); traverse(Tree1(t)); /* evaluate activate expression */ setloc(t); emit("coact"); if (Val0(Tree0(t)) == AUGACT) emit("asgn"); break; case N_Alt: /* alternation */ lab = alclab(2); emitl("mark", lab); loopsp->markcount++; traverse(Tree0(t)); /* evaluate first alternative */ loopsp->markcount--; emit("esusp"); /* and suspend with its result */ emitl("goto", lab+1); emitlab(lab); traverse(Tree1(t)); /* evaluate second alternative */ emitlab(lab+1); break; case N_Augop: /* augmented assignment */ case N_Binop: /* or a binary operator */ emit("pnull"); traverse(Tree1(t)); if (TType(t) == N_Augop) emit("dup"); traverse(Tree2(t)); setloc(t); binop((int)Val0(Tree0(t))); break; case N_Bar: /* repeated alternation */ lab = alclab(1); emitlab(lab); emit("mark0"); /* fail if expr fails first time */ loopsp->markcount++; traverse(Tree0(t)); /* evaluate first alternative */ loopsp->markcount--; emitl("chfail", lab); /* change to loop on failure */ emit("esusp"); /* suspend result */ break; case N_Break: /* break expression */ if (loopsp->breaklab <= 0) nfatal(t, "invalid context for break"); else { for (i = 0; i < loopsp->markcount; i++) emit("unmark"); loopsave = *loopsp--; traverse(Tree0(t)); *++loopsp = loopsave; emitl("goto", loopsp->breaklab); } break; case N_Case: /* case expression */ lab = alclab(1); casesp++; casesp->endlab = lab; casesp->deftree = NULL; emit("mark0"); loopsp->markcount++; traverse(Tree0(t)); /* evaluate control expression */ loopsp->markcount--; emit("eret"); traverse(Tree1(t)); /* do rest of case (CLIST) */ if (casesp->deftree != NULL) { /* evaluate default clause */ emit("pop"); traverse(casesp->deftree); } else emit("efail"); emitlab(lab); /* end label */ casesp--; break; case N_Ccls: /* case expression clause */ if (TType(Tree0(t)) == N_Res && /* default clause */ Val0(Tree0(t)) == DEFAULT) { if (casesp->deftree != NULL) nfatal(t, "more than one default clause"); else casesp->deftree = Tree1(t); } else { /* case clause */ lab = alclab(1); emitl("mark", lab); loopsp->markcount++; emit("ccase"); traverse(Tree0(t)); /* evaluate selector */ setloc(t); emit("eqv"); loopsp->markcount--; emit("unmark"); emit("pop"); traverse(Tree1(t)); /* evaluate expression */ emitl("goto", casesp->endlab); /* goto end label */ emitlab(lab); /* label for next clause */ } break; case N_Clist: /* list of case clauses */ traverse(Tree0(t)); traverse(Tree1(t)); break; case N_Conj: /* conjunction */ if (Val0(Tree0(t)) == AUGAND) { emit("pnull"); } traverse(Tree1(t)); if (Val0(Tree0(t)) != AUGAND) emit("pop"); traverse(Tree2(t)); if (Val0(Tree0(t)) == AUGAND) { setloc(t); emit("asgn"); } break; case N_Create: /* create expression */ creatsp++; creatsp->nextlab = loopsp->nextlab; creatsp->breaklab = loopsp->breaklab; loopsp->nextlab = 0; /* make break and next illegal */ loopsp->breaklab = 0; lab = alclab(3); emitl("goto", lab+2); /* skip over code for co-expression */ emitlab(lab); /* entry point */ emit("pop"); /* pop the result from activation */ emitl("mark", lab+1); loopsp->markcount++; traverse(Tree0(t)); /* traverse code for co-expression */ loopsp->markcount--; setloc(t); emit("coret"); /* return to activator */ emit("efail"); /* drive co-expression */ emitlab(lab+1); /* loop on exhaustion */ emit("cofail"); /* and fail each time */ emitl("goto", lab+1); emitlab(lab+2); emitl("create", lab); /* create entry block */ loopsp->nextlab = creatsp->nextlab; /* legalize break and next */ loopsp->breaklab = creatsp->breaklab; creatsp--; break; case N_Cset: /* cset literal */ emitn("cset", (int)Val0(t)); break; case N_Elist: /* expression list */ n = traverse(Tree0(t)); n += traverse(Tree1(t)); break; case N_Empty: /* a missing expression */ emit("pnull"); break; case N_Field: /* field reference */ emit("pnull"); traverse(Tree0(t)); setloc(t); emits("field", Str0(Tree1(t))); break; case N_Id: /* identifier */ emitn("var", (int)Val0(t)); break; case N_If: /* if expression */ if (TType(Tree2(t)) == N_Empty) { lab = 0; emit("mark0"); } else { lab = alclab(2); emitl("mark", lab); } loopsp->markcount++; traverse(Tree0(t)); loopsp->markcount--; emit("unmark"); traverse(Tree1(t)); if (lab > 0) { emitl("goto", lab+1); emitlab(lab); traverse(Tree2(t)); emitlab(lab+1); } break; case N_Int: /* integer literal */ emitn("int", (int)Val0(t)); break; case N_Apply: /* application */ traverse(Tree0(t)); traverse(Tree1(t)); emitn("invoke", -1); break; case N_Invok: /* invocation */ if (TType(Tree0(t)) != N_Empty) { traverse(Tree0(t)); } else { emit("pushn1"); /* default to -1(e1,...,en) */ } n = traverse(Tree1(t)); setloc(t); emitn("invoke", n); n = 1; break; case N_Key: /* keyword reference */ setloc(t); emitn("keywd", (int)Val0(t)); break; case N_Limit: /* limitation */ traverse(Tree1(t)); setloc(t); emit("limit"); loopsp->markcount++; traverse(Tree0(t)); loopsp->markcount--; emit("lsusp"); break; case N_List: /* list construction */ emit("pnull"); if (TType(Tree0(t)) == N_Empty) n = 0; else n = traverse(Tree0(t)); setloc(t); emitn("llist", n); n = 1; break; case N_Loop: /* loop */ switch ((int)Val0(Tree0(t))) { case EVERY: lab = alclab(2); loopsp++; loopsp->ltype = EVERY; loopsp->nextlab = lab; loopsp->breaklab = lab + 1; loopsp->markcount = 1; emit("mark0"); traverse(Tree1(t)); emit("pop"); if (TType(Tree2(t)) != N_Empty) { /* every e1 do e2 */ emit("mark0"); loopsp->ltype = N_Loop; loopsp->markcount++; traverse(Tree2(t)); loopsp->markcount--; emit("unmark"); } emitlab(loopsp->nextlab); emit("efail"); emitlab(loopsp->breaklab); loopsp--; break; case REPEAT: lab = alclab(3); loopsp++; loopsp->ltype = N_Loop; loopsp->nextlab = lab + 1; loopsp->breaklab = lab + 2; loopsp->markcount = 1; emitlab(lab); emitl("mark", lab); traverse(Tree1(t)); emitlab(loopsp->nextlab); emit("unmark"); emitl("goto", lab); emitlab(loopsp->breaklab); loopsp--; break; case SUSPEND: /* suspension expression */ if (creatsp > creatstk) nfatal(t, "invalid context for suspend"); lab = alclab(2); loopsp++; loopsp->ltype = EVERY; /* like every ... do for next */ loopsp->nextlab = lab; loopsp->breaklab = lab + 1; loopsp->markcount = 1; emit("mark0"); traverse(Tree1(t)); setloc(t); emit("psusp"); emit("pop"); if (TType(Tree2(t)) != N_Empty) { /* suspend e1 do e2 */ emit("mark0"); loopsp->ltype = N_Loop; loopsp->markcount++; traverse(Tree2(t)); loopsp->markcount--; emit("unmark"); } emitlab(loopsp->nextlab); emit("efail"); emitlab(loopsp->breaklab); loopsp--; break; case WHILE: lab = alclab(3); loopsp++; loopsp->ltype = N_Loop; loopsp->nextlab = lab + 1; loopsp->breaklab = lab + 2; loopsp->markcount = 1; emitlab(lab); emit("mark0"); traverse(Tree1(t)); if (TType(Tree2(t)) != N_Empty) { emit("unmark"); emitl("mark", lab); traverse(Tree2(t)); } emitlab(loopsp->nextlab); emit("unmark"); emitl("goto", lab); emitlab(loopsp->breaklab); loopsp--; break; case UNTIL: lab = alclab(4); loopsp++; loopsp->ltype = N_Loop; loopsp->nextlab = lab + 2; loopsp->breaklab = lab + 3; loopsp->markcount = 1; emitlab(lab); ark", lab+1); traverse(Tree1(t)); emit("unmark"); emit("efail"); emitlab(lab+1); emitl("mark", lab); traverse(Tree2(t)); emitlab(loopsp->nextlab); emit("unmark"); emitl("goto", lab); emitlab(loopsp->breaklab); loopsp--; break; } break; case N_Next: /* next expression */ if (loopsp < loopstk || loopsp->nextlab <= 0) nfatal(t, "invalid context for next"); else { if (loopsp->ltype != EVERY && loopsp->markcount > 1) for (i = 0; i < loopsp->markcount - 1; i++) emit("unmark"); emitl("goto", loopsp->nextlab); } break; case N_Not: /* not expression */ lab = alclab(1); emitl("mark", lab); loopsp->markcount++; traverse(Tree0(t)); loopsp->markcount--; emit("unmark"); emit("efail"); emitlab(lab); emit("pnull"); break; case N_Proc: /* procedure */ loopsp = loopstk; loopsp->nextlab = 0; loopsp->breaklab = 0; loopsp->markcount = 0; casesp = casestk; creatsp = creatstk; writecheck(fprintf(codefile, "proc %s\n", Str0(Tree0(t)))); lout(codefile); cout(codefile); emit("declend"); setloc(t); if (TType(Tree1(t)) != N_Empty) { lab = alclab(1); emitl("init", lab); emitl("mark", lab); traverse(Tree1(t)); emit("unmark"); emitlab(lab); } if (TType(Tree2(t)) != N_Empty) traverse(Tree2(t)); setloc(Tree3(t)); emit("pfail"); emit("end"); if (!silent) fprintf(stderr, " %s (%d/%d)\n", Str0(Tree0(t)), (int)((word *)tfree - (word *)tree), (int)tsize); break; case N_Real: /* real literal */ emitn("real", (int)Val0(t)); break; case N_Ret: /* return expression */ if (creatsp > creatstk) nfatal(t, "invalid context for return or fail"); if (Val0(Tree0(t)) != FAIL) { lab = alclab(1); emitl("mark", lab); loopsp->markcount++; traverse(Tree1(t)); loopsp->markcount--; setloc(t); emit("pret"); emitlab(lab); } setloc(t); emit("pfail"); break; case N_Scan: /* scanning expression */ if (Val0(Tree0(t)) == SCANASGN) emit("pnull"); traverse(Tree1(t)); if (Val0(Tree0(t)) == SCANASGN) emit("sdup"); setloc(t); emit("bscan"); traverse(Tree2(t)); setloc(t); emit("escan"); if (Val0(Tree0(t)) == SCANASGN) emit("asgn"); break; case N_Sect: /* section operation */ emit("pnull"); traverse(Tree1(t)); traverse(Tree2(t)); if (Val0(Tree0(t)) == PCOLON || Val0(Tree0(t)) == MCOLON) emit("dup"); traverse(Tree3(t)); setloc(Tree0(t)); if (Val0(Tree0(t)) == PCOLON) emit("plus"); else if (Val0(Tree0(t)) == MCOLON) emit("minus"); setloc(t); emit("sect"); break; case N_Slist: /* semicolon-separated expr list */ lab = alclab(1); emitl("mark", lab); loopsp->markcount++; traverse(Tree0(t)); loopsp->markcount--; emit("unmark"); emitlab(lab); traverse(Tree1(t)); break; case N_Str: /* string literal */ emitn("str", (int)Val0(t)); break; case N_To: /* to expression */ emit("pnull"); traverse(Tree0(t)); traverse(Tree1(t)); emit("push1"); setloc(t); emit("toby"); break; case N_ToBy: /* to-by expression */ emit("pnull"); traverse(Tree0(t)); traverse(Tree1(t)); traverse(Tree2(t)); setloc(t); emit("toby"); break; case N_Unop: /* unary operator */ unopa((int)Val0(Tree0(t)),t); traverse(Tree1(t)); setloc(t); unopb((int)Val0(Tree0(t))); break; default: emitn("?????", TType(t)); tsyserr("traverse: undefined node type"); } return n; } /* * binop emits code for binary operators. For non-augmented operators, * the name of operator is emitted. For augmented operators, an "asgn" * is emitted after the name of the operator. */static novalue binop(op)int op; { register int asgn; register char *name; asgn = 0; switch (op) { case ASSIGN: name = "asgn"; break; case CARETASGN: asgn++; case CARET: name = "power"; break; case CONCATASGN: asgn++; case CONCAT: name = "cat"; break; case DIFFASGN: asgn++; case DIFF: name = "diff"; break; case AUGEQV: asgn++; case EQUIV: name = "eqv"; break; case INTERASGN: asgn++; case INTER: name = "inter"; break; case LBRACK: name = "subsc"; break; case LCONCATASGN: asgn++; case LCONCAT: name = "lconcat"; break; case AUGSEQ: asgn++; case LEXEQ: name = "lexeq";
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:icont Folder:tcode.
+++++ Continued from previous card +++++
break; case AUGSGE: asgn++; case LEXGE: name = "lexge"; break; case AUGSGT: asgn++; case LEXGT: name = "lexgt"; break; case AUGSLE: asgn++; case LEXLE: name = "lexle"; break; case AUGSLT: asgn++; case LEXLT: name = "lexlt"; break; case AUGSNE: asgn++; case LEXNE: name = "lexne"; break; case MINUSASGN: asgn++; case MINUS: name = "minus"; break; case MODASGN: asgn++; case MOD: name = "mod"; break; case AUGNEQV: asgn++; case NOTEQUIV: name = "neqv"; break; case AUGEQ: asgn++; case NUMEQ: name = "numeq"; break; case AUGGE: asgn++; case NUMGE: name = "numge"; break; case AUGGT: asgn++; case NUMGT: name = "numgt"; break; case AUGLE: asgn++; case NUMLE: name = "numle"; break; case AUGLT: asgn++; case NUMLT: name = "numlt"; break; case AUGNE: asgn++; case NUMNE: name = "numne"; break; case PLUSASGN: asgn++; case PLUS: name = "plus"; break; case REVASSIGN: name = "rasgn"; break; case REVSWAP: name = "rswap"; break; case SLASHASGN: asgn++; case SLASH: name = "div"; break; case STARASGN: asgn++; case STAR: name = "mult"; break; case SWAP: name = "swap"; break; case UNIONASGN: asgn++; case UNION: name = "unions"; break; default: emitn("?binop", op); tsyserr("binop: undefined binary operator"); } emit(name); if (asgn) emit("asgn"); }/* * unopa and unopb handle code emission for unary operators. unary operator * sequences that are the same as binary operator sequences are recognized * by the lexical analyzer as binary operators. For example, ~===x means to * do three tab(match(...)) operations and then a cset complement, but the * lexical analyzer sees the operator sequence as the "neqv" binary * operation. unopa and unopb unravel tokens of this form. * * When a N_Unop node is encountered, unopa is called to emit the necessary * number of "pnull" operations to receive the intermediate results. This * amounts to a pnull for each operation. */static novalue unopa(op,t)int op;nodeptr t; { switch (op) { case NOTEQUIV: /* unary ~ and three = operators */ emit("pnull"); case LEXNE: /* unary ~ and two = operators */ case EQUIV: /* three unary = operators */ emit("pnull"); case NUMNE: /* unary ~ and = operators */ case UNION: /* two unary + operators */ case DIFF: /* two unary - operators */ case LEXEQ: /* two unary = operators */ case INTER: /* two unary * operators */ emit("pnull"); case BACKSLASH: /* unary \ operator */ case BANG: /* unary ! operator */ case CARET: /* unary ^ operator */ case PLUS: /* unary + operator */ case TILDE: /* unary ~ operator */ case MINUS: /* unary - operator */ case NUMEQ: /* unary = operator */ case STAR: /* unary * operator */ case QMARK: /* unary ? operator */ case SLASH: /* unary / operator */ emit("pnull"); break; case DOT: /* unary . operator */ if (TType(Tree1(t)) == N_Int || TType(Tree1(t)) == N_Real) { if (!silent) { nfatal(t,"dereferencing operator applied to numeric literal"); tfatals--; /* for now */ nocode--; } } emit("pnull"); break; default: tsyserr("unopa: undefined unary operator"); } } /* * unopb is the back-end code emitter for unary operators. It emits * the operations represented by the token op. For tokens representing * a single operator, the name of the operator is emitted. For tokens * representing a sequence of operators, recursive calls are used. In * such a case, the operator sequence is "scanned" from right to left * and unopb is called with the token for the appropriate operation. * * For example, consider the sequence of calls and code emission for "~===": * unopb(NOTEQUIV) ~=== * unopb(NUMEQ) = * emits "tabmat" * unopb(NUMEQ) = * emits "tabmat" * unopb(NUMEQ) = * emits "tabmat" * emits "compl" */static novalue unopb(op)int op; { register char *name; switch (op) { case DOT: /* unary . operator */ name = "value"; break; case BACKSLASH: /* unary \ operator */ name = "nonnull"; break; case BANG: /* unary ! operator */ name = "bang"; break; case CARET: /* unary ^ operator */ name = "refresh"; break; case UNION: /* two unary + operators */ unopb(PLUS); case PLUS: /* unary + operator */ name = "number"; break; case NOTEQUIV: /* unary ~ and three = operators */ unopb(NUMEQ); case LEXNE: /* unary ~ and two = operators */ unopb(NUMEQ); case NUMNE: /* unary ~ and = operators */ unopb(NUMEQ); case TILDE: /* unary ~ operator (cset compl) */ name = "compl"; break; case DIFF: /* two unary - operators */ unopb(MINUS); case MINUS: /* unary - operator */ name = "neg"; break; case EQUIV: /* three unary = operators */ unopb(NUMEQ); case LEXEQ: /* two unary = operators */ unopb(NUMEQ); case NUMEQ: /* unary = operator */ name = "tabmat"; break; case INTER: /* two unary * operators */ unopb(STAR); case STAR: /* unary or */ name = "size"; break; case QMARK: /* unary ? operator */ name = "random"; break; case SLASH: /* unary / operator */ name = "null"; break; default: emitn("?unop", op); tsyserr("unopb: undefined unary operator"); } emit(name); } /* * setloc emits "filen" and "line" directives for the source location of * node n. A directive is only emitted if the corrosponding value * has changed since the last time setloc was called. Note: File(n) * reportedly occasionally points at uninitialized data, producing * bogus results (as well as reams of filen commands). We could use * comfile here instead; that would ignore any #line directives. */static char *lastfiln = NULL;static int lastline = 0;#ifdef EvalTracestatic int lastcol = 0;#endif /* EvalTrace */static novalue setloc(n)nodeptr n; { if ((n != NULL) && (TType(n) != N_Empty) && (File(n) != NULL) && (lastfiln == NULL || strcmp(File(n), lastfiln) != 0)) { lastfiln = File(n); emits("filen", lastfiln); } if (Line(n) != lastline) { lastline = Line(n); emitn("line", Line(n)); }#ifdef EvalTrace if (Col(n) != lastcol) { lastcol = Col(n); emitn("colm", Col(n)); }#endif /* EvalTrace */ }#ifdef MultipleRuns/* * Reinitialize last file name and line number for repeated runs. */novalue tcodeinit() { lastfiln = NULL;#ifdef EvalTrace lastcol = 0;#endif /* EvalTrace */ }#endif /* Multiple Runs */ /* * The emit* routines output ucode to codefile. The various routines are: * * emitlab(l) - emit "lab" instruction for label l. * emit(s) - emit instruction s. * emitl(s,a) - emit instruction s with reference to label a. * emitn(s,n) - emit instruction s with numeric argument a. * emits(s,a) - emit instruction s with string argument a. */static novalue emitlab(l)int l; { writecheck(fprintf(codefile, "lab L%d\n", l)); }static novalue emit(s)char *s; { writecheck(fprintf(codefile, "\t%s\n", s)); }static novalue emitl(s, a)char *s;int a; { writecheck(fprintf(codefile, "\t%s\tL%d\n", s, a)); }static novalue emitn(s, a)char *s;int a; { writecheck(fprintf(codefile, "\t%s\t%d\n", s, a)); }static novalue emits(s, a)char *s, *a; { writecheck(fprintf(codefile, "\t%s\t%s\n", s, a)); } /* * alclab allocates n labels and returns the first. For the interpreter, * labels are restarted at 1 for each procedure, while in the compiler, * they start at 1 and increase throughout the entire compilation. */static int alclab(n)int n; { register int lab; lab = nextlab; nextlab += n; return lab; } :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:icont Folder:tlex.c
/* * tlex.c -- the lexical analyzer. */#include "::h:config.h"#include "tproto.h"#include "trans.h"#include "token.h"#include "tlex.h"#include "tree.h"#include <ctype.h>#if MACINTOSH#if MPW#include <CursorCtl.h>#define CURSORINTERVAL 100#endif /* MPW */#endif /* MACINTOSH *//* * Prototypes. */hidden int ctlesc Params((noargs));hidden struct toktab *findres Params((noargs));hidden struct toktab *getident Params((int ac,int *cc));hidden struct toktab *getnum Params((int ac,int *cc));hidden struct toktab *getopr Params((int ac,int *cc));hidden struct toktab *getstring Params((int ac,int *cc));hidden int hexesc Params((noargs));hidden int nextchar Params((noargs));hidden int octesc Params((int ac));hidden int setfilenm Params((int c));hidden int setlineno Params((noargs));#define isletter(s) (isupper(c) | islower(c))#if !EBCDIC#define tonum(c) (isdigit(c) ? (c - '0') : ((c & 037) + 9))/* * esctab - translates single-character escapes in string literals. */static char esctab[] = { 000, 001, 002, 003, 004, 005, 006, 007, /* NUL-BEL */ 010, 011, 012, 013, 014, 015, 016, 017, /* BS -SI */ 020, 021, 022, 023, 024, 025, 026, 027, /* DLE-ETB */ 030, 031, 032, 033, 034, 035, 036, 037, /* CAN-US */ ' ', '!', '"', '#', '$', '%', '&', '\'', /* !"#$%&' */ '(', ')', '*', '+', ',', '-', '.', '/', /* ()*+,-./ */ 000, 001, 002, 003, 004, 005, 006, 007, /* 01234567 */ 010, 011, ':', ';', '<', '=', '>', '?', /* 89:;<=>? */ '@', 'A', '\b', 'C', 0177, 033, 014, 'G', /* @ABCDEFG */ 'H', 'I', 'J', 'K', '\n', 'M', '\n', 'O', /* HIJKLMNO */ 'P', 'Q', '\r', 'S', '\t', 'U', 013, 'W', /* PQRSTUVW */ 'X', 'Y', 'Z', '[', '\\', ']', '^', '_', /* XYZ[\]^_ */ '`', 'a', '\b', 'c', 0177, 033, 014, 'g', /* `abcdefg */ 'h', 'i', 'j', 'k', '\n', 'm', '\n', 'o', /* hijklmno */ 'p', 'q', '\r', 's', '\t', 'u', 013, 'w', /* pqrstuvw */ 'x', 'y', 'z', '{', '|', '}', '~', 0177, /* xyz{|}~ */ 0200, 0201, 0202, 0203, 0204, 0205, 0206, 0207, 0210, 0211, 0212, 0213, 0214, 0215, 0216, 0217, 0220, 0221, 0222, 0223, 0224, 0225, 0226, 0227, 0230, 0231, 0232, 0233, 0234, 0235, 0236, 0237, 0240, 0241, 0242, 0243, 0244, 0245, 0246, 0247, 0250, 0251, 0252, 0253, 0254, 0255, 0256, 0257, 0260, 0261, 0262, 0263, 0264, 0265, 0266, 0267, 0270, 0271, 0272, 0273, 0274, 0275, 0276, 0277, 0300, 0301, 0302, 0303, 0304, 0305, 0306, 0307, 0310, 0311, 0312, 0313, 0314, 0315, 0316, 0317, 0320, 0321, 0322, 0323, 0324, 0325, 0326, 0327, 0330, 0331, 0332, 0333, 0334, 0335, 0336, 0337, 0340, 0341, 0342, 0343, 0344, 0345, 0346, 0347, 0350, 0351, 0352, 0353, 0354, 0355, 0356, 0357, 0360, 0361, 0362, 0363, 0364, 0365, 0366, 0367, 0370, 0371, 0372, 0373, 0374, 0375, 0376, 0377, };#else /* !EBCDIC *//* * This is the EBCDIC table for handling escapes. */static char esctab[] = { 0x00, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, 0x08, 0x09, 0x0a, 0x0b, 0x0c, 0x0d, 0x0e, 0x0f, 0x10, 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17, 0x18, 0x19, 0x1a, 0x1b, 0x1c, 0x1d, 0x1e, 0x1f, 0x20, 0x21, 0x22, 0x23, 0x24, 0x25, 0x26, 0x27, 0x28, 0x29, 0x2a, 0x2b, 0x2c, 0x2d, 0x2e, 0x2f, 0x30, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, 0x37, 0x38, 0x39, 0x3a, 0x3b, 0x3c, 0x3d, 0x3e, 0x3f, ' ', 0x41, 0x42, 0x43, 0x44, 0x45, 0x46, 0x47, 0x48, 0x49, 0x4a, 0x4b, 0x4c, 0x4d, 0x4e, 0x4f, 0x50, 0x51, 0x52, 0x53, 0x54, 0x55, 0x56, 0x57, 0x58, 0x59, 0x5a, 0x5b, 0x5c, 0x5d, 0x5e, 0x5f, 0x60, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68, 0x69, 0x6a, 0x6b, 0x6c, 0x6d, 0x6e, 0x6f, 0x70, 0x71, 0x72, 0x73, 0x74, 0x75, 0x76, 0x77, 0x78, 0x79, 0x7a, 0x7b, 0x7c, 0x7d, 0x7e, 0x7f, 0x80, 'a', 0x16, 'c', 0x07, 0x27, 0x0c, 'g', 'h', 'i', 0x8a, 0x8b, 0x8c, 0x8d, 0x8e, 0x8f, 0x90, 'j', 'k', 0x25, 'm', 0x15, 'o', 'p', 'q', 0x0d, 0x9a, 0x9b, 0x9c, 0x9d, 0x9e, 0x9f, 0xa0, 0xa1, 's', 0x05, 'u', 0x0b, 'w', 'x', 'y', 'z', 0xaa, 0xab, 0xac, 0xad, 0xae, 0xaf, 0xb0, 0xb1, 0xb2, 0xb3, 0xb4, 0xb5, 0xb6, 0xb7, 0xb8, 0xb9, 0xba, 0xbb, 0xbc, 0xbd, 0xbe, 0xbf, 0xc0, 'A', 0x16, 'C', 0x07, 0x27, 0x0c, 'G', 'H', 'I', 0xca, 0xcb, 0xcc, 0xcd, 0xce, 0xcf, 0xd0, 'J', 'K', 0x25, 'M', 0x15, 'O', 'P', 'Q', 0x0d, 0xda, 0xdb, 0xdc, 0xdd, 0xde, 0xdf, 0xe0, 0xe1, 'S', 0x05, 'U', 0x0b, 'W', 'X', 'Y', 'Z', 0xea, 0xeb, 0xec, 0xed, 0xee, 0xef, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 0xfa, 0xfb, 0xfc, 0xfd, 0xfe, 0xff, };#endif /* !EBCDIC */struct node tok_loc = {0, NULL, 0, 0}; /* "model" node containing location of current token */ /* * yylex - find the next token in the input stream, and return its token * type and value to the parser. * * Variables of interest: * * cc - character following last token. * comflag - set if in a comment. * nlflag - set if a newline was between the last token and the current token * lastend - set if the last token was an Ender. * lastval - when a semicolon is inserted and returned, lastval gets the * token value that would have been returned if the semicolon hadn't * been inserted. */static struct toktab *lasttok = NULL;static int lastend = 0;static int eofflag = 0;static int cc = '\n';int yylex() { register struct toktab *t; register int c; int nlflag; int comflag; static nodeptr lastval; static struct node semi_loc; if (lasttok != NULL) { /* * A semicolon was inserted and returned on the last call to yylex, * instead of going to the input, return lasttok and set the * appropriate variables. */ yylval = lastval; tok_loc = *lastval; t = lasttok; goto ret; } nlflag = 0; comflag = 0;loop: c = cc; /* * Remember where a semicolon will go if we insert one. */ semi_loc.n_file = tok_loc.n_file; semi_loc.n_line = in_line; semi_loc.n_col = incol; /* * Skip whitespace and comments and process #line directives. */ while (c == Comment || isspace(c)) { if (c == '\n') { nlflag++; c = NextChar; if (c == Comment) { /* * Check for #line directive at start of line. */ if (('l' == (c = NextChar)) && ('i' == (c = NextChar)) && ('n' == (c = NextChar)) && ('e' == (c = NextChar))) { c = setlineno(); while ((c == ' ') || (c == '\t')) c = NextChar; if (c != EOF && c != '\n') c = setfilenm(c); } while (c != EOF && c != '\n') c = NextChar; } } else { if (c == Comment) { while (c != EOF && c != '\n') c = NextChar; } else { c = NextChar; } } } /* * A token is the next thing in the input. Set token location to * the current line and column. */ tok_loc.n_line = in_line; tok_loc.n_col = incol; if (c == EOF) { /* * End of file has been reached. Set eofflag, return T_Eof, and * set cc to EOF so that any subsequent scans also return T_Eof. */ if (eofflag++) { eofflag = 0; cc = '\n'; yylval = NULL; return 0; } cc = EOF; t = T_Eof; yylval = NULL; goto ret; } /* * Look at current input character to determine what class of token * is next and take the appropriate action. Note that the various * token gathering routines write a value into cc. */ if (isalpha(c) || (c == '_')) { /* gather ident or reserved word */ if ((t = getident(c, &cc)) == NULL) goto loop; } else if (isdigit(c)) { /* gather numeric literal */ if ((t = getnum(c, &cc)) == NULL) goto loop; } else if (c == '"' || c == '\'') { /* gather string or cset literal */ if ((t = getstring(c, &cc)) == NULL) goto loop; } else { /* gather longest legal operator */ if ((t = getopr(c, &cc)) == NULL) goto loop; yylval = OpNode(t->t_type); } if (nlflag && lastend && (t->t_flags & Beginner)) { /* * A newline was encountered between the current token and the last, * the last token was an Ender, and the current token is a Beginner. * Return a semicolon and save the current token in lastval. */ lastval = yylval; lasttok = t; tok_loc = semi_loc; yylval = OpNode(SEMICOL); return SEMICOL; }ret: /* * Clear lasttok, set lastend if the token being returned is an * Ender, and return the token. */ lasttok = 0; lastend = t->t_flags & Ender; return (t->t_type); } #ifdef MultipleRuns/* * yylexinit - initialize variables for multiple runs */novalue yylexinit() { lasttok = NULL; lastend = 0; eofflag = 0; cc = '\n'; } #endif /* MultipleRuns *//* * getident - gather an identifier beginning with ac. The character * following identifier goes in cc. */static struct toktab *getident(ac, cc)int ac;int *cc; { register int c; register char *p; register struct toktab *t; c = ac; p = strf; /* * Copy characters into string space until a non-alphanumeric character * is found. */ do { if (p >= stre) tsyserr("out of string space"); *p++ = c; c = NextChar; } while (isalnum(c) || (c == '_')); if (p >= stre) tsyserr("out of string space"); *p++ = 0; *cc = c; /* * If the identifier is a reserved word, make a ResNode for it and return * the token value. Otherwise, install it with putid, make an * IdNode for it, and return. */ if ((t = findres()) != NULL) { yylval = ResNode(t->t_type); return t; } else { yylval = IdNode(putid((int)(p-strf))); return (struct toktab *)T_Ident; } } /* * findres - if the string just copied into the string space by getident * is a reserved word, return a pointer to its entry in the token table. * Return NULL if the string isn't a reserved word. */static struct toktab *findres() { register struct toktab *t; register char c, *p; p = strf; c = *p; if (!islower(c)) return NULL; /* * Point t at first reserved word that starts with c (if any). */ if ((t = restab[c - 'a']) == NULL) return NULL; /* * Search through reserved words, stopping when a match is found * or when the current reserved word doesn't start with c. */ while (t->t_word[0] == c) { if (strcmp(t->t_word, p) == 0) return t; t++; } return NULL; } /* * getnum - gather a numeric literal starting with ac and put the * character following the literal into *cc. */static struct toktab *getnum(ac, cc)int ac;int *cc; { register int c, r, state; char *p; int realflag; c = ac; r = tonum(c); p = strf; state = 0; realflag = 0; for (;;) { if (p >= stre) tsyserr("out of string space"); *p++ = c; c = NextChar; switch (state) { case 0: /* integer part */ if (isdigit(c)) { r = r * 10 + tonum(c); continue; } if (c == '.') { state = 1; realflag++; continue; } if (c == 'e' || c == 'E') { state = 2; realflag++; continue; } if (c == 'r' || c == 'R') { state = 5; if (r < 2 || r > 36) tfatal("invalid radix for integer literal", (char *)NULL); continue; } break; case 1: /* fractional part */ if (isdigit(c)) continue; if (c == 'e' || c == 'E') { state = 2; continue; } break; case 2: /* optional exponent sign */ if (c == '+' || c == '-') { state = 3; continue; } case 3: /* first digit after e, e+, or e- */ if (isdigit(c)) { state = 4; continue; } tfatal("invalid real literal", (char *)NULL); break; case 4: /* remaining digits after e */ if (isdigit(c)) continue; break; case 5: /* first digit after r */ if ((isdigit(c) || isletter(c)) && tonum(c) < r) { state = 6; continue; } tfatal("invalid integer literal", (char *)NULL); break; case 6: /* remaining digits after r */ if (isdigit(c) || isletter(c)) { if (tonum(c) >= r) { /* illegal digit for radix r */ tfatal("invalid digit in integer literal", (char *)NULL); r = tonum('z'); /* prevent more messages */ } continue; } break; } break; } if (p >= stre) tsyserr("out of string space"); *p++ = 0; *cc = c; if (realflag) { yylval = RealNode(putid((int)(p-strf))); return T_Real; } yylval = IntNode(putid((int)(p-strf))); return T_Int; } /* * getstring - gather a string literal starting with ac and place the * character following the literal in *cc. */static struct toktab *getstring(ac, cc)int ac;int *cc; { register int c, sc; register char *p; char *lc; int len; sc = c = ac; p = strf; lc = 0; while ((c = NextChar) != sc && c != '\n' && c != EOF) { contin: if (c == '_') lc = p; else if (!isspace(c)) lc = 0; if (c == Escape) { c = NextChar;#ifdef VarTran *p++ = Escape;#else /* VarTran */ if (isoctal(c)) c = octesc(c); else if (c == 'x') c = hexesc(); else if (c == '^') c = ctlesc(); else c = esctab[c];#endif /* VarTran */ if (c == EOF) goto noquote; } if (p >= stre) tsyserr("out of string space"); *p++ = c; } if (p >= stre) tsyserr("out of string space"); *p++ = 0; if (c == sc) *cc = ' '; else { if (c == '\n' && lc) { p = lc; while ((c = NextChar) != EOF && isspace(c)) ; if (c != EOF) goto contin; }noquote: tfatal("unclosed quote", (char *)NULL); *cc = c; } if (ac == '"') { /* a string literal */ len = p - strf; yylval = StrNode(putid((int)len), len); return T_String; } else { /* a cset literal */ len = p - strf; yylval = CsetNode(putid((int)len), len); return T_Cset; } } #ifndef VarTran/* * ctlesc - translate a control escape -- backslash followed by * caret and one character. */static int ctlesc() { register int c; c = NextChar; if (c == EOF) return EOF; return (c & 037); } /* * octesc - translate an octal escape -- backslash followed by * one, two, or three octal digits. */static int octesc(ac)int ac; { register int c, nc, i; c = 0; nc = ac; i = 1; do { c = (c << 3) | (nc - '0'); nc = NextChar; if (nc == EOF) return EOF; } while (isoctal(nc) && i++ < 3); PushChar(nc); return (c & 0377); } /* * hexesc - translate a hexadecimal escape -- backslash-x * followed by one or two hexadecimal digits. */static int hexesc() { register int c, nc, i; c = 0; i = 0; while (i++ < 2) { nc = NextChar; if (nc == EOF) return EOF; if (nc >= 'a' && nc <= 'f') nc -= 'a' - 10; else if (nc >= 'A' && nc <= 'F') nc -= 'A' - 10; else if (isdigit(nc)) nc -= '0'; else { PushChar(nc); break; } c = (c << 4) | nc; } return c; }
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:icont Folder:tlex.c
+++++ Continued from previous card +++++
#endif /* VarTran */ /* * getopr - find the longest legal operator and return a pointer * to its entry in the token table. */static struct toktab *getopr(ac, cc)int ac;int *cc; { register struct optab *state; register char c, i; state = state0; c = ac; for (;;) { while ((i = state->o_input) && c != i) state++; switch (state->o_action) { case A_Goto: state = (struct optab *) state->o_val; c = NextChar; continue; case A_Error: tfatal("invalid character", (char *)NULL); *cc = ' '; return NULL; case A_Return: *cc = c; return (struct toktab *)(state->o_val); case A_Immret: *cc = ' '; return (struct toktab *)(state->o_val); } } } /* * setlineno - set line number from #line comment, return following char. */static int setlineno() { register int c; while ((c = NextChar) == ' ' || c == '\t') ; if (c < '0' || c > '9') { tfatal("no line number in #line directive", ""); while (c != EOF && c != '\n') c = NextChar; return c; } in_line = 0; while (c >= '0' && c <= '9') { in_line = in_line * 10 + (c - '0'); c = NextChar; } return c; } /* * setfilenm - set file name from #line comment, return following char. * * Assigning to comfile here does not provide the fine-grained * control over filenames required by a real macro processor. * setloc() in tcode.c ought to be restored to its earlier form and * the initialization of filenames fixed. */static int setfilenm(c)register int c; { extern char *comfile; register char *p; while (c == ' ' || c == '\t') c = NextChar; if (c != '"') { tfatal("'\"' missing from file name in #line directive", ""); while (c != EOF && c != '\n') c = NextChar; return c; } p = strf; while ((c = NextChar) != '"' && c != EOF && c != '\n') { if (p >= stre) tsyserr("out of string space"); *p++ = c; } *p++ = '\0'; if (c == '"') { tok_loc.n_file = putid((int)(p-strf)); return NextChar; } else { tfatal("'\"' missing from file name in #line directive", ""); return c; } } /* * nextchar - return the next character in the input. */static int nextchar() { register int c;#if MACINTOSH#if MPW { static short cursorcount = CURSORINTERVAL; if (--cursorcount == 0) { RotateCursor(0); cursorcount = CURSORINTERVAL; } }#endif /* MPW */#endif /* MACINTOSH */ if (c = peekc) { peekc = 0; return c; } c = getc(srcfile); switch (c) { case EOF: if (incol) { c = '\n'; in_line++; incol = 0; peekc = EOF; break; } else { in_line = 0; incol = 0; break; } case '\n': in_line++; incol = 0; break; case '\t': incol = (incol | 7) + 1; break; case '\b': if (incol) incol--; break; default: incol++; } return c; } :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:icont Folder:tlex.h
/* * trans.c - main control of the translation process. */#include "::h:config.h"#include "tproto.h"#include "::h:version.h"#include "globals.h"#include "trans.h"#include "general.h"#include "tsym.h"#include "tree.h"#include "token.h"/* * Prototypes. */FILE *preprocess Params((char *filename));novalue trans1 Params((char *filename));char *comfile = NULL;int tfatals; /* total number of fatal errors */int nocode; /* non-zero to suppress code generation */int in_line; /* current input line number */int incol; /* current input column number */int peekc; /* one-character look ahead */FILE *srcfile; /* current input file */FILE *codefile; /* current ucode output file */FILE *globfile; /* current global table output file */ /* * translate a number of files, returning an error count */int trans(ifiles)char **ifiles; { tmalloc(); /* allocate memory for translation */#ifdef MultipleRuns yylexinit(); /* initialize lexical analyser */ tcodeinit(); /* initialize code generator */#endif /* Multiple Runs */ while (*ifiles) trans1(*ifiles++); /* translate each file in turn */ tmfree(); /* free memory used for translation */ /* * Report information about errors and warnings and be correct about it. */ if (tfatals == 1) fprintf(stderr, "1 error\n"); else if (tfatals > 1) fprintf(stderr, "%d errors\n", tfatals); else if (!silent) fprintf(stderr, "No errors\n"); return tfatals; } /* * translate one file. */static novalue trans1(filename)char *filename;{ char oname[MaxFileName]; /* buffer for constructing file names */ comfile = filename; tfatals = 0; /* reset error counts */ nocode = 0; /* allow code generation/* in_line = 1; /* start with line 1, column 0 */ incol = 0; peekc = 0; /* clear character lookahead */ if (m4pre) srcfile = preprocess(filename); else if (strcmp(filename,"-") == 0) { srcfile = stdin; filename = "stdin"; } else srcfile = fopen(filename,"r"); if (srcfile == NULL) quitf("cannot open %s",filename); if (!silent) fprintf(stderr, "%s:\n",filename);#ifndef VarTran /* * Form names for the .u1 and .u2 files and open them. * Write the ucode version number to the .u2 file. */ makename(oname, TargetDir, filename, U1Suffix); codefile = fopen(oname, "w"); if (codefile == NULL) quitf("cannot create %s", oname); makename(oname, TargetDir, filename, U2Suffix); globfile = fopen(oname, "w"); if (globfile == NULL) quitf("cannot create %s", oname); writecheck(fprintf(globfile,"version\t%s\n",UVersion));#endif /* VarTran */ tok_loc.n_file = filename; in_line = 1; tminit(); /* Initialize data structures */ yyparse(); /* Parse the input */ /* * Close the output files and the input file. */#ifndef VarTran if (fclose(codefile) != 0 || fclose(globfile) != 0) quit("cannot close ucode file");#endif /* VarTran */ if (!m4pre) fclose(srcfile); /* "else" is below in conditional */#if UNIX else if (pclose(srcfile) != 0) quit("m4 terminated abnormally");#endif /* UNIX */ } /* * writecheck - check the return code from a stdio output operation */novalue writecheck(rc) { if (rc < 0) quit("cannot write to ucode file"); } /* * open a pipe to the preprocessor. */static FILE *preprocess(filename)char *filename;{#if MACINTOSH#if MPW/* #pragma unused(filename) */ return NULL; /* to prevent compiler warning */#endif /* MPW */#endif /* MACINTOSH */#if UNIX { FILE *f, *popen(); char *s = alloc((unsigned int)(4+strlen(filename))); sprintf(s,"m4 %s",filename); f = popen(s,"r"); free(s); return f; }#endif /* UNIX */} :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:icont Folder:trans.h
#if IntBits == 16#ifdef strlen#undef strlen /* defined in some contexts */#endif /* strlen */#endif /* IntBits == 16 *//* * External definitions needed throughout translator. */extern int yychar; /* parser's current input token type */extern int yynerrs; /* number of errors in parse */extern int nocode; /* true to suppress code generation */extern int trace; /* initial setting of &trace */extern int in_line; /* current line number in input */extern int incol; /* current column number in input */extern int peekc; /* one character look-ahead */extern FILE *srcfile; /* current input file */extern FILE *codefile; /* current icode output file */extern FILE *globfile; /* current global output file */extern char *strings; /* string space */extern char *stre; /* end of string space */extern char *strf; /* free pointer for string space */ :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:icont Folder:tree.c
/* * tree.c -- functions for constructing parse trees */#include "::h:config.h"#include "tproto.h"#include "tree.h"/* * tree[1-6] construct parse tree nodes with specified values. tfree * points at the next free word in the parse tree space. Nodes are * built by copying argument values into successive locations starting * at tfree. Parameters a and b are line and column information, * while parameters c through f are values to be assigned to n_field[0-3]. * Note that this could be done with a single routine; a separate routine * for each node size is used for speed and simplicity. */nodeptr tree1(type)int type; { register nodeptr t; t = tfree; tfree = (nodeptr) ((word *)tfree + 1); if (tfree > tend) tsyserr("out of tree space"); t->n_type = type; return t; }nodeptr tree2(type, loc_model)int type;nodeptr loc_model; { register nodeptr t; t = tfree; tfree = (nodeptr) ((word *)tfree + 4); if (tfree > tend) tsyserr("out of tree space"); t->n_type = type; t->n_file = loc_model->n_file; t->n_line = loc_model->n_line; t->n_col = loc_model->n_col; return t; }nodeptr tree3(type, loc_model, c)int type;nodeptr loc_model;nodeptr c; { register nodeptr t; t = tfree; tfree = (nodeptr) ((word *)tfree + 5); if (tfree > tend) tsyserr("out of tree space"); t->n_type = type; t->n_file = loc_model->n_file; t->n_line = loc_model->n_line; t->n_col = loc_model->n_col; t->n_field[0].n_ptr = c; return t; }nodeptr tree4(type, loc_model, c, d)int type;nodeptr loc_model;nodeptr c, d; { register nodeptr t; t = tfree; tfree = (nodeptr) ((word *)tfree + 6); if (tfree > tend) tsyserr("out of tree space"); t->n_type = type; t->n_file = loc_model->n_file; t->n_line = loc_model->n_line; t->n_col = loc_model->n_col; t->n_field[0].n_ptr = c; t->n_field[1].n_ptr = d; return t; }nodeptr tree5(type, loc_model, c, d, e)int type;nodeptr loc_model;nodeptr c, d, e; { register nodeptr t; t = tfree; tfree = (nodeptr) ((word *)tfree + 7); if (tfree > tend) tsyserr("out of tree space"); t->n_type = type; t->n_file = loc_model->n_file; t->n_line = loc_model->n_line; t->n_col = loc_model->n_col; t->n_field[0].n_ptr = c; t->n_field[1].n_ptr = d; t->n_field[2].n_ptr = e; return t; }nodeptr tree6(type, loc_model, c, d, e, f)int type;nodeptr loc_model;nodeptr c, d, e, f; { register nodeptr t; t = tfree; tfree = (nodeptr) ((word *)tfree + 8); if (tfree > tend) tsyserr("out of tree space"); t->n_type = type; t->n_file = loc_model->n_file; t->n_line = loc_model->n_line; t->n_col = loc_model->n_col; t->n_field[0].n_ptr = c; t->n_field[1].n_ptr = d; t->n_field[2].n_ptr = e; t->n_field[3].n_ptr = f; return t; }nodeptr int_leaf(type, loc_model, c)int type;nodeptr loc_model;int c; { register nodeptr t; t = tfree; tfree = (nodeptr) ((word *)tfree + 5); if (tfree > tend) tsyserr("out of tree space"); t->n_type = type; t->n_file = loc_model->n_file; t->n_line = loc_model->n_line; t->n_col = loc_model->n_col; t->n_field[0].n_val = c; return t; }nodeptr c_str_leaf(type, loc_model, c)int type;nodeptr loc_model;char *c; { register nodeptr t; t = tfree; tfree = (nodeptr) ((word *)tfree + 5); if (tfree > tend) tsyserr("out of tree space"); t->n_type = type; t->n_file = loc_model->n_file; t->n_line = loc_model->n_line; t->n_col = loc_model->n_col; t->n_field[0].n_str = c; return t; }nodeptr i_str_leaf(type, loc_model, c, d)int type;nodeptr loc_model;char *c;int d; { register nodeptr t; t = tfree; tfree = (nodeptr) ((word *)tfree + 6); if (tfree > tend) tsyserr("out of tree space"); t->n_type = type; t->n_file = loc_model->n_file; t->n_line = loc_model->n_line; t->n_col = loc_model->n_col; t->n_field[0].n_str = c; t->n_field[1].n_val = d; return t; }/* * Clear the tree space by setting the free pointer back to the first word * of the tree space. */novalue treeinit() { tfree = tree; } :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:icont Folder:tree.h
/* * Structure of a tree node. */typedef struct node *nodeptr;#define NodeFields 4struct node { int n_type; /* node type */ char *n_file; /* name of file containing source program */ int n_line; /* line number in source program */ int n_col; /* column number in source program */ union { long n_val; /* integer-valued fields */ char *n_str; /* string-valued fields */ nodeptr n_ptr; /* subtree pointers */ } n_field[NodeFields]; };/* * Macros to access fields of parse tree nodes. */#define TType(t) t->n_type#define File(t) t->n_file#define Line(t) t->n_line#define Col(t) t->n_col#define Tree0(t) t->n_field[0].n_ptr#define Tree1(t) t->n_field[1].n_ptr#define Tree2(t) t->n_field[2].n_ptr#define Tree3(t) t->n_field[3].n_ptr#define Val0(t) t->n_field[0].n_val#define Val1(t) t->n_field[1].n_val#define Val2(t) t->n_field[2].n_val#define Val3(t) t->n_field[3].n_val#define Val4(t) t->n_field[4].n_val#define Str0(t) t->n_field[0].n_str#define Str1(t) t->n_field[1].n_str#define Str2(t) t->n_field[2].n_str#define Str3(t) t->n_field[3].n_str/* * External declarations. */extern nodeptr tree; /* parse tree space */extern nodeptr tfree; /* free pointer for tree space */extern nodeptr tend; /* end of tree space */extern nodeptr yylval; /* parser's current token value */extern struct node tok_loc; /* "model" token holding current location *//* * Node types. */#define N_Activat 1 /* activation control structure */#define N_Alt 2 /* alternation operator */#define N_Augop 3 /* augmented operator */#define N_Bar 4 /* generator control structure */#define N_Binop 5 /* other binary operator */#define N_Break 6 /* break statement */#define N_Case 7 /* case statement */#define N_Ccls 8 /* case clause */#define N_Clist 9 /* list of case clauses */#define N_Conj 10 /* conjunction operator */#define N_Create 11 /* create control structure */#define N_Cset 12 /* cset literal */#define N_Elist 14 /* list of expressions */#define N_Empty 15 /* empty expression or statement */#define N_Field 16 /* record field reference */#define N_Id 17 /* identifier token */#define N_If 18 /* if-then-else statement */#define N_Int 19 /* integer literal */#define N_Invok 20 /* invocation */#define N_Key 21 /* keyword */#define N_Limit 22 /* LIMIT control structure */#define N_List 23 /* [ ... ] style list */#define N_Loop 24 /* while, until, every, or repeat */#define N_Not 25 /* not prefix control structure */#define N_Next 26 /* next statement */#define N_Op 27 /* operator token */#define N_Proc 28 /* procedure */#define N_Real 29 /* real literal */#define N_Res 30 /* reserved word token */#define N_Ret 31 /* fail, return, or succeed */#define N_Scan 32 /* scan-using statement */#define N_Sect 33 /* s[i:j] (section) */#define N_Slist 34 /* list of statements */#define N_Str 35 /* string literal */#define N_Susp 36 /* suspend statement */#define N_To 37 /* TO operator */#define N_ToBy 38 /* TO-BY operator */#define N_Unop 39 /* unary operator */#define N_Apply 40 /* procedure application *//* * Macros for constructing basic nodes. */#define CsetNode(a,b) i_str_leaf(N_Cset,&tok_loc,a,b) #define IdNode(a) c_str_leaf(N_Id,&tok_loc,a) #define IntNode(a) c_str_leaf(N_Int,&tok_loc,a) #define OpNode(a) int_leaf(N_Op,&tok_loc,a) #define RealNode(a) c_str_leaf(N_Real,&tok_loc,a) #define ResNode(a) int_leaf(N_Res,&tok_loc,a) #define StrNode(a,b) i_str_leaf(N_Str,&tok_loc,a,b) :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:icont Folder:tsym.c
/* * tsym.c -- functions for symbol table management. */#include "::h:config.h"#include "tproto.h"#include "globals.h"#include "trans.h"#include "token.h"#include "tsym.h"#ifndef VarTran#include "lfile.h"#endif /* VarTran *//* * Prototypes. */hidden struct tgentry *alcglob Params((struct tgentry *blink, char *name,int flag,int nargs));hidden struct tientry *alcid Params((char *nam,int len));hidden struct tcentry *alclit Params((struct tcentry *blink, char *name, int len,int flag));hidden struct tlentry *alcloc Params((struct tlentry *blink, char *name,int flag));hidden struct tcentry *clookup Params((char *id,int flag));hidden struct tgentry *glookup Params((char *id));hidden struct tlentry *llookup Params((char *id));hidden novalue putglob Params((char *id,int id_type, int n_args));hidden int streq Params((int len,char *s1,char *s2));#ifdef DeBugTransnovalue cdump Params((noargs));novalue gdump Params((noargs));novalue ldump Params((noargs));#endif /* DeBugTrans */ /* * putid - install the identifier named by the string starting at strf * and extending for len bytes. The installation entails making an * entry in the identifier hash table and then making an identifier * table entry for it with alcid. A side effect of installation * is the incrementing of strf by the length of the string, thus * "saving" it. * * Nothing is changed if the identifier has already been installed. */char *putid(len)int len; { register int hash; register char *s; register struct tientry *ip; int l; /* * Compute hash value by adding bytes and masking result with imask. * (Recall that imask is ihsize-1.) */ s = strf; hash = 0; l = len; while (l--) hash += *s++ & 0377; s = strf; l = len; hash &= imask; /* * If the identifier hasn't been installed, install it. */ if ((ip = ihash[hash]) != NULL) { /* collision */ for (;;) { /* work down i_blink chain until id is found or the end of the chain is reached */ if (l == ip->i_length && streq(l, s, ip->i_name)) return (ip->i_name); /* id is already installed */ if (ip->i_blink == NULL) { /* end of chain */ ip->i_blink = alcid(s,l); strf += l; return s; } ip = ip->i_blink; } } /* * Hashed to an empty slot. */ ihash[hash] = alcid(s,l); strf += l; return s; } /* * streq - compare s1 with s2 for len bytes, and return 1 for equal, * 0 for not equal. */static int streq(len, s1, s2)register int len;register char *s1, *s2; { while (len--) if (*s1++ != *s2++) return 0; return 1; } /* * alcid - get the next free identifier table entry, and fill it in with * the specified values. */static struct tientry *alcid(nam, len)char *nam;int len; { register struct tientry *ip; if (ifree >= &itable[isize]) tsyserr("out of identifier table space"); ip = ifree++; ip->i_blink = NULL; ip->i_name = nam; ip->i_length = len; return ip; } #ifndef VarTran/* * loc_init - clear the local symbol table. */novalue loc_init() { register struct tlentry **lp; register struct tcentry **cp; static int maxlfree = 0; static int maxcfree = 0; /* clear local table */ maxlfree = (maxlfree > lfree-ltable) ? maxlfree : lfree-ltable; for (lp = lhash; lp < &lhash[lhsize]; lp++) *lp = NULL; lfree = ltable; /* clear constant table */ maxcfree = (maxcfree > ctfree-ctable) ? maxcfree : ctfree-ctable; for (cp = chash; cp < &chash[chsize]; cp++) *cp = NULL; ctfree = ctable; } /* * install - put an identifier into the global or local symbol table. * The basic idea here is to look in the right table and install * the identifier if it isn't already there. Some semantic checks * are performed. */novalue install(name, flag, argcnt)char *name;int flag, argcnt; { union { struct tgentry *gp; struct tlentry *lp; } p; switch (flag) { case F_Global: /* a variable in a global declaration */ if ((p.gp = glookup(name)) == NULL) putglob(name, flag, argcnt); else p.gp->g_flag |= flag; break; case F_Proc|F_Global: /* procedure declaration */ case F_Record|F_Global: /* record declaration */ case F_Builtin|F_Global: /* external declaration */ if ((p.gp = glookup(name)) == NULL) putglob(name, flag, argcnt); else if ((p.gp->g_flag & (~F_Global)) == 0) { /* superfluous global declaration for record or proc */ p.gp->g_flag |= flag; p.gp->g_nargs = argcnt; } else /* the user can't make up his mind */ tfatal("inconsistent redeclaration", name); break; case F_Static: /* static declaration */ case F_Dynamic: /* local declaration (possibly implicit?) */ case F_Argument: /* formal parameter */ if ((p.lp = llookup(name)) == NULL) putloc(name,flag); else if (p.lp->l_flag == flag) /* previously declared as same type */ tfatal("redeclared identifier", name); else /* previously declared as different type */ tfatal("inconsistent redeclaration", name); break; default: tsyserr("install: unrecognized symbol table flag."); } } tloc - make a local symbol table entry and return the index * of the entry in lhash. alcloc does the work if there is a collision. */int putloc(id,id_type)char *id;int id_type; { register struct tlentry *ptr; if ((ptr = llookup(id)) == NULL) { /* add to head of hash chain */ ptr = lhash[lhasher(id)]; lhash[lhasher(id)] = alcloc(ptr, id, id_type); return (lhash[lhasher(id)] - ltable); } return (ptr - ltable); } /* * putglob makes a global symbol table entry. alcglob does the work if there * is a collision. */static novalue putglob(id, id_type, n_args)char *id;int id_type, n_args; { register struct tgentry *ptr; if ((ptr = glookup(id)) == NULL) { /* add to head of hash chain */ ptr = ghash[ghasher(id)]; ghash[ghasher(id)] = alcglob(ptr, id, id_type, n_args); } } /* * putlit makes a constant symbol table entry and returns the index * of the entry in chash. alclit does the work if there is a collision. */int putlit(id, idtype, len)char *id;int len, idtype; { register struct tcentry *ptr; if ((ptr = clookup(id,idtype)) == NULL) { /* add to head of hash chain */ ptr = chash[chasher(id)]; chash[chasher(id)] = alclit(ptr, id, len, idtype); return (chash[chasher(id)] - ctable); } return (ptr - ctable); } /* * llookup looks up id in local symbol table and returns pointer to * to it if found or NULL if not present. */static struct tlentry *llookup(id)char *id; { register struct tlentry *ptr; ptr = lhash[lhasher(id)]; while (ptr != NULL && ptr->l_name != id) ptr = ptr->l_blink; return ptr; } /* * glookup looks up id in global symbol table and returns pointer to * to it if found or NULL if not present. */static struct tgentry *glookup(id)char *id; { register struct tgentry *ptr; ptr = ghash[ghasher(id)]; while (ptr != NULL && ptr->g_name != id) { ptr = ptr->g_blink; } return ptr; } /* * clookup looks up id in constant symbol table and returns pointer to * to it if found or NULL if not present. */static struct tcentry *clookup(id,flag)char *id;int flag; { register struct tcentry *ptr; ptr = chash[chasher(id)]; while (ptr != NULL && (ptr->c_name != id || ptr->c_flag != flag)) ptr = ptr->c_blink; return ptr; } /* * klookup looks up keyword named by id in keyword table and returns * its number (keyid). */int klookup(id)register char *id; { register struct keyent *kp; for (kp = keytab; kp->keyid >= 0; kp++) if (strcmp(kp->keyname,id) == 0) return (kp->keyid); return 0; } #ifdef DeBugTrans/* * ldump displays local symbol table to stdout. */novalue ldump() { register int i; register struct tlentry *lptr; fprintf(stderr,"Dump of local symbol table (%d entries)\n",lfree-ltable); fprintf(stderr," loc blink id (name) flags\n"); for (i = 0; i < lhsize; i++) for (lptr = lhash[i]; lptr != NULL; lptr = lptr->l_blink) fprintf(stderr,"%5d %5d %5d %20s %7o\n", lptr-ltable, lptr->l_blink, lptr->l_name, lptr->l_name, lptr->l_flag); fflush(stderr); } /* * gdump displays global symbol table to stdout. */novalue gdump() { register int i; register struct tgentry *gptr; fprintf(stderr,"Dump of global symbol table (%d entries)\n", (int)(gfree-gtable)); fprintf(stderr," loc blink id (name) flags nargs\n"); for (i = 0; i < ghsize; i++) for (gptr = ghash[i]; gptr != NULL; gptr = gptr->g_blink) fprintf(stderr,"%5d %5d %5d %20s %7o %8d\n", gptr-gtable, gptr->g_blink, gptr->g_name, gptr->g_name, gptr->g_flag, gptr->g_nargs); fflush(stderr); } /* * cdump displays constant symbol table to stdout. */novalue cdump() { register int i; register struct tcentry *cptr; fprintf(stderr,"Dump of constant symbol table (%d entries)\n",ctfree-ctable); fprintf(stderr," loc blink id (name) flags\n"); for (i = 0; i < chsize; i++) for (cptr = chash[i]; cptr != NULL; cptr = cptr->c_blink) fprintf(stderr,"%5d %5d %5d %20s %7o\n", cptr-ctable, cptr->c_blink, cptr->c_name, cptr->c_name, cptr->c_flag); fflush(stderr); }#endif /* DeBugTrans */ /* * alcloc allocates a local symbol table entry, fills in fields with * specified values and returns offset of new entry. */static struct tlentry *alcloc(blink, name, flag)struct tlentry *blink;char *name;int flag; { register struct tlentry *lp; if (lfree >= <able[lsize]) tsyserr("out of local symbol table space"); lp = lfree++; lp->l_blink = blink; lp->l_name = name; lp->l_flag = flag; return lp; }/* * alcglob allocates a global symbol table entry, fills in fields with * specified values and returns offset of new entry. */static struct tgentry *alcglob(blink, name, flag, nargs)struct tgentry *blink;char *name;int flag, nargs; { register struct tgentry *gp; if (gfree >= >able[gsize]) tsyserr("out of global symbol table space"); gp = gfree++; gp->g_blink = blink; gp->g_name = name; gp->g_flag = flag; gp->g_nargs = nargs; return gp; } /* * alclit allocates a constant symbol table entry, fills in fields with * specified values and returns offset of new entry. */static struct tcentry *alclit(blink, name, len, flag)struct tcentry *blink;char *name;int len, flag; { register struct tcentry *cp; if (ctfree >= &ctable[csize]) tsyserr("out of constant table space"); cp = ctfree++; cp->c_blink = blink; cp->c_name = name; cp->c_length = len; cp->c_flag = flag; return cp; } /* * lout dumps local symbol table to fd, which is a .u1 file. */novalue lout(fd)FILE *fd; { register int i; register struct tlentry *lp; i = 0; for (lp = ltable; lp < lfree; lp++) writecheck(fprintf(fd, "\tlocal\t%d,%06o,%s\n", i++, lp->l_flag, lp->l_name)); } /* * cout dumps constant symbol table to fd, which is a .u1 file. */novalue cout(fd)FILE *fd; { register int l; register char *c; register struct tcentry *cp; int i; i = 0; for (cp = ctable; cp < ctfree; cp++) { writecheck(fprintf(fd, "\tcon\t%d,%06o", i++, cp->c_flag)); if (cp->c_flag & F_IntLit) writecheck(fprintf(fd, ",%d,%s\n", strlen(cp->c_name), cp->c_name)); else if (cp->c_flag & F_RealLit) writecheck(fprintf(fd, ",%s\n", cp->c_name)); else { c = cp->c_name; l = cp->c_length - 1; writecheck(fprintf(fd, ",%d", l)); while (l--) writecheck(fprintf(fd, ",%03o", *c++ & 0377)); writecheck(putc('\n', fd)); } } } /* * rout dumps a record declaration for name to file fd, which is a .u2 file. */novalue rout(fd,name)FILE *fd;char *name; { register int i; register struct tlentry *lp; writecheck(fprintf(fd, "record\t%s,%d\n", name, (int)(lfree-ltable))); i = 0; for (lp = ltable; lp < lfree; lp++) writecheck(fprintf(fd, "\t%d,%s\n", i++, lp->l_name)); } /* * gout writes various items to fd, which is a .u2 file. These items * include: implicit status, tracing activation, link directives, * and the global table. */novalue gout(fd)FILE *fd; { register int i; register char *name; register struct tgentry *gp; struct lfile *lfl; if (uwarn) name = "error"; else name = "local"; writecheck(fprintf(fd, "impl\t%s\n", name)); if (trace) writecheck(fprintf(fd, "trace\n")); lfl = lfiles; while (lfl) { writecheck(fprintf(fd,"link\t%s.u1\n",lfl->lf_name)); lfl = lfl->lf_link; } lfiles = 0; writecheck(fprintf(fd, "global\t%d\n", (int)(gfree-gtable))); i = 0; for (gp = gtable; gp < gfree; gp++) writecheck(fprintf(fd, "\t%d,%06o,%s,%d\n", i++, gp->g_flag, gp->g_name, gp->g_nargs)); }#endif /* VarTran */ :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:icont Folder:tsym.h
/* * Structures for symbol table entries. */struct tlentry { /* local try */ struct tlentry *l_blink; /* link for bucket chain */ char *l_name; /* name of variable */ int l_flag; /* variable flags */ };struct tgentry { /* global table entry */ struct tgentry *g_blink; /* link for bucket chain */ char *g_name; /* name of variable */ int g_flag; /* variable flags */ int g_nargs; /* number of args (procedure) or */ }; /* number of fields (record) */struct tcentry { /* constant table entry */ struct tcentry *c_blink; /* link for bucket chain */ char *c_name; /* pointer to string */ int c_length; /* length of string */ int c_flag; /* type of literal flag */ };struct tientry { /* identifier table entry */ struct tientry *i_blink; /* link for bucket chain */ char *i_name; /* pointer to string */ int i_length; /* length of string */ };/* * Flag values. */#define F_Global 01 /* variable declared global externally */#define F_Proc 04 /* procedure */#define F_Record 010 /* record */#define F_Dynamic 020 /* variable declared local dynamic */#define F_Static 040 /* variable declared local static */#define F_Builtin 0100 /* identifier refers to built-in procedure */#define F_ImpError 0400 /* procedure has default error */#define F_Argument 01000 /* variable is a formal parameter */#define F_IntLit 02000 /* literal is an integer */#define F_RealLit 04000 /* literal is a real */#define F_StrLit 010000 /* literal is a string */#define F_CsetLit 020000 /* literal is a cset *//* * Symbol table region pointers. */extern struct tlentry **lhash; /* hash area for local table */extern struct tgentry **ghash; /* hash area for global table */extern struct tcentry **chash; /* hash area for constant table */extern struct tientry **ihash; /* hash area for identifier table */extern struct tlentry *ltable; /* local table */extern struct tgentry *gtable; /* global table */extern struct tcentry *ctable; /* constant table */extern struct tientry *itable; /* identifier table */extern struct tlentry *lfree; /* free pointer for local table */extern struct tgentry *gfree; /* free pointer for global table */extern struct tcentry *ctfree; /* free pointer for constant table */extern struct tientry *ifree; /* free pointer for identifier table *//* * Structure for keyword table. */struct keyent { char *keyname; int keyid; };extern struct keyent keytab[]; /* keyword table *//* * Hash functions for symbol tables. */#define ghasher(x) (((word)x)&gmask) /* global symbol table */#define lhasher(x) (((word)x)&lmask) /* local symbol table */#define chasher(x) (((word)x)&cmask) /* constant symbol table */ :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:icont Folder:util.c
/* * util.c -- general utility functions. */#include <ctype.h>#include "::h:config.h"#include "tproto.h"#include "::h:cpuconf.h"#include "globals.h"#include "general.h"#include "trans.h"#include "tree.h"extern int optind;extern char *ofile;/* * The following code is operating-system dependent [@util.01]. Define the * characters that terminate a file name prefix. */#if PORT#define Prefix "/"Deliberate Syntax Error#endif /* PORT */#if AMIGA#define Prefix "/:"#endif /* AMIGA */#if ATARI_ST#define Prefix "/:\\"#endif /* ATARI_ST */#if HIGHC_386 || MSDOS || OS2#define Prefix "/:\\"#endif /* HIGHC_386 || MSDOS || OS2 */#if MACINTOSH#define Prefix ":"#endif /* MACINTOSH */#if MVS || VM#define Prefix ""#endif /* MVS || VM */#if UNIX#define Prefix "/"#endif /* UNIX */#if VMS#define Prefix "]:"#endif /* VMS *//* * End of operating-system specific code. */ /* * Information about Icon functions. *//* * Number of arguments. *//* * Names of Icon functions. */char *ftable[] = {#ifdef PreProcess/* define(FncDef,"$1"`,') *//* define(FncDefV,"$1"`,') *//* include(../h/fdefs.h) /* *//* undefine(`FncDef') *//* undefine(`FncDefV') *//* */#else /* PreProcess */#define FncDef(p,n) Lit(p),#define FncDefV(p) Lit(p),#include "::h:fdefs.h"#undef FncDef#undef FncDefV#endif /* PreProcess */ };int ftbsize = sizeof(ftable)/sizeof(char *); /* * alloc - allocate n bytes */pointer alloc(n)unsigned int n; { pointer a; if (!(a = malloc((msize)n))) quit("out of memory"); return a; } /* * salloc - allocate and initialize string */char *salloc(s)char *s; { return strcpy((char *)alloc((unsigned int)(strlen(s)+1)),s); } /* * tcalloc - allocate and zero m*n bytes */pointer tcalloc(m,n)unsigned int m, n; { pointer a; if (!(a = calloc(m,n))) quit("out of memory"); return a; } /* * fparse - break a file name down into component parts. * Result is a pointer to a struct of static pointers good until the next call. */struct fileparts *fparse(s)char *s; { static char buf[MaxFileName+2]; static struct fileparts fp; int n; char *p, *q; char *index(); q = s; fp.ext = p = s + strlen(s); while (--p >= s) { if (*p == '.' && *fp.ext == '\0') fp.ext = p; else if (index(Prefix,*p)) { q = p+1; break; } } fp.dir = buf; n = q - s; strncpy(fp.dir,s,n); fp.dir[n] = '\0'; fp.name = buf + n + 1; n = fp.ext - q; strncpy(fp.name,q,n); fp.name[n] = '\0'; return &fp; } /* * makename - make a file name, optionally substituting a new dir and/or ext */char *makename(dest,d,name,e)char *dest, *d, *name, *e; { struct fileparts fp; fp = *fparse(name); if (d != NULL) fp.dir = d; if (e != NULL) fp.ext = e; sprintf(dest,"%s%s%s",fp.dir,fp.name,fp.ext); return dest; } /* * quit - immediate exit with error message */novalue quit(msg)char *msg; { quitf(msg,""); } /* * quitf - immediate exit with message format and argument */novalue quitf(msg,arg)char *msg, *arg; { extern char *progname; fprintf(stderr,"%s: ",progname); fprintf(stderr,msg,arg); fprintf(stderr,"\n");#ifndef VarTran unlink(ofile); /* remove bad icode file */#endif /* VarTran */ exit(ErrorExit); } /* * tsyserr is called for fatal errors. The message s is produced and the * translator exits. */novalue tsyserr(s)char *s; { if (tok_loc.n_file) fprintf(stderr, "File %s; ", tok_loc.n_file); fprintf(stderr, "Line %d # %s\n", in_line, s); exit(ErrorExit); } /* * round2 - round an integer up to the next power of 2. */unsigned int round2(n)unsigned int n; { unsigned int b = 1; while (b < n) b <<= 1; return b; } /* * sizearg - process -S command option. */struct keyptr { /* structure for listing option chars */ char *cmd; /* option character(s) */ unsigned int *valp; /* pointer to value word */ };static struct keyptr keytable[] = { /* maps keys to store addresses */#define Size(cmd,vname,defalt) cmd, &vname,#define MinSize(x,y,z)#include "sizes.h" /* initialize from "sizes.h" data */#undef Size#undef MinSize 0, 0, /* terminate with null entry */ };novalue sizearg(arg,argv)char *arg;char **argv; { struct keyptr *k; /* key table pointer */ char *s; /* value string pointer */ int v; /* option value */ for (k = keytable; k->cmd; k++) /* search for key match */ if (arg[0] == k->cmd[0] && (arg[0] != 'h' || arg[1] == k->cmd[1])) break; if (k->cmd == NULL) /* abort if not found */ quitf("unrecognized -S option: -S%s",arg); if (arg[0] == 'h') s = &arg[2]; /* find value */ else s = &arg[1]; if (*s == '\0') { /* if value is in next arg */ s = argv[optind++]; if (s == NULL) quitf("missing value: -S%s", arg); } v = (int)atol(s); /* convert integer -- check */ if (v <= 0) quitf("illegal value: -S%s", arg); *k->valp = v; /* store result */ } /* * smatch - case-insensitive string match - returns nonzero if they match */int smatch(s,t)char *s, *t; { char a, b; for (;;) { while (*s == *t) if (*s++ == '\0') return 1; else t++; a = *s++; b = *t++; if (isupper(a)) a = tolower(a); if (isupper(b)) b = tolower(b); if (a != b) return 0; } } :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:extcall.c
/* * fconv.c -- abs, cset, integer, numeric, proc, real, string. */#include "::h:config.h"#include "::h:rt.h"#include "rproto.h"#ifdef PreProcess/* include(../M4/fncs.m4) /* *//* */#endif /* PreProcess *//* * abs(x) - absolute value of x. */FncDcl(abs,1) { switch (cvnum(&Arg1)) { /* * If Arg1 is convertible to a numeric, turn Arg0 into * a descriptor for the appropriate type and value. If the * conversion fails, produce an error. This code assumes that * n = -n is always valid, which is not necessarily correct. */ case T_Integer: MakeInt(Abs(IntVal(Arg1)), &Arg0); break; case T_Real: makereal(BlkLoc(Arg1)->realblk.realval, &Arg0); if (BlkLoc(Arg0)->realblk.realval < 0.0) BlkLoc(Arg0)->realblk.realval = -BlkLoc(Arg0)->realblk.realval; break;#ifdef LargeInts case T_Bignum: cpbignum(&Arg1, &Arg0); BlkLoc(Arg0)->bignumblk.sign = 0; break;#endif /* LargeInts */ default: RunErr(102, &Arg1); } Return; } /* * cset(x) - convert x to cset. */FncDcl(cset,1) { register int i; register struct b_cset *bp; int *cs, csbuf[CsetSize]; if (blkreq((word)sizeof(struct b_cset)) == Error) RunErr(0, NULL); if (Arg1.dword == D_Cset) /* * Arg1 already a cset, just return it. */ Arg0 = Arg1; else if (cvcset(&Arg1, &cs, csbuf) != CvtFail) { /* * Arg1 was convertible to cset and the result resides in csbuf. * Allocate * a cset, make Arg0 a descriptor for it and copy the * bits from csbuf into it. */ Arg0.dword = D_Cset; bp = alccset(); BlkLoc(Arg0) = (union block *) bp; for (i = 0; i < CsetSize; i++) bp->bits[i] = cs[i]; } else /* Not a cset nor convertible to one. */ Fail; Return; } /* * integer(x) - convert x to integer. */FncDcl(integer,1) {#ifdef LargeInts switch (cvnum(&Arg1)) { case T_Integer: case T_Bignum: Arg0 = Arg1; break; case T_Real: if (realtobig(&Arg1, &Arg0) == Error) /* alcbignum failed */ RunErr(0, NULL); break;#else /* LargeInts */ switch (cvint(&Arg1)) { case T_Integer: Arg0 = Arg1; break;#endif /* LargeInts */ default: Fail; } Return; } /* * numeric(x) - convert x to numeric type. */FncDcl(numeric,1) { switch (cvnum(&Arg1)) { case T_Integer:#ifdef LargeInts case T_Bignum:#endif /* LargeInts */ case T_Real: Arg0 = Arg1; break; default: Fail; } Return; } /* * proc(x,i) - convert x to a procedure if possible; use i to * resolve ambiguous string names. */FncDcl(proc,2) { char sbuf[MaxCvtLen]; long i; /* * If Arg1 is already a proc, just return it in Arg0. */ Arg0 = Arg1; if (Arg0.dword == D_Proc) Return; if (cvstr(&Arg0, sbuf) == CvtFail) Fail; /* * Arg2 defaults to 1. */ if (defshort(&Arg2, 1) == Error) RunErr(0, NULL); i = IntVal(Arg2); if (i < 1 || i > 3) RunErr(205, &Arg2); /* * Attempt to convert Arg0 to a procedure descriptor using args to * discriminate between procedures with the same names. Fail if * the conversion isn't successful. */ if (strprc(&Arg0,i) == CvtFail) Fail; Return; } /* * real(x) - convert x to real. */FncDcl(real,1) { /* * If Arg1 is already a real, just return it. Otherwise convert it and * return it, failing if the conversion is unsuccessful. */ if (Arg1.dword == D_Real) Arg0 = Arg1; else if (cvreal(&Arg1) == T_Real) Arg0 = Arg1; else Fail; Return; } /* * string(x) - convert x to string. */FncDcl(string,1) { char sbuf[MaxCvtLen]; Arg0 = Arg1; switch (cvstr(&Arg0, sbuf)) { /* * If Arg1 is not a string, allocate it and return it; if it is a * string, just return it; fail otherwise. */ case Cvt: /* * Allocate converted string */ if (strreq(StrLen(Arg0)) == Error) RunErr(0, NULL); StrLoc(Arg0) = alcstr(StrLoc(Arg0), StrLen(Arg0)); case NoCvt: Return; default: Fail; } } :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:fmath.c
/* * fmath.c -- sin, cos, tan, acos, asin, atan, dtor, rtod, exp, log, sqrt */#include <math.h>#include "::h:config.h"#include "::h:rt.h"#include "rproto.h"#ifdef MathFncs/* * The following code is operating-system dependent [@fmath.01]. Include * system-dependent files and declarations. */#if PORT /* probably #include <errno.h> */#endif /* PORT */#if AMIGA || HIGHC_386 || MACINTOSH || VMS#include <errno.h>#endif /* AMIGA || HIGHC_386 ... */#if ATARI_ST#if LATTICE#include <error.h>#else /* LATTICE */#include <errno.h>#endif /* LATTICE */#endif /* ATARI_ST */#if MSDOS#if !MWC#include <errno.h>#endif /* !MWC */#if MICROSOFTint errno;#endif /* MICROSOFT */#endif /* MSDOS */#if OS2#if MICROSOFTint errno;#endif /* MICROSOFT */#endif /* OS2 */#if MVS || VM#include <errno.h>#ifdef SASC#include <lcmath.h>#define PI M_PI#endif /* SASC */#endif /* MVS || VM */#if UNIX#include <errno.h>int errno;#endif /* UNIX *//* * End of operating-system specific code. */#ifndef PI#define PI 3.14159#endif /* PI */#ifdef PreProcess/* include(../M4/fncs.m4) /* *//* */#endif /* PreProcess *//* * sin(x), x in radians */FncDcl(sin,1) { int t; double sin(); if ((t = cvreal(&Arg1)) == CvtFail) RunErr(102, &Arg1); if (makereal(sin(BlkLoc(Arg1)->realblk.realval), &Arg0) == Error) RunErr(0, NULL); Return; } /* * cos(x), x in radians */FncDcl(cos,1) { int t; if ((t = cvreal(&Arg1)) == CvtFail) RunErr(102, &Arg1); if (makereal(cos(BlkLoc(Arg1)->realblk.realval), &Arg0) == Error) RunErr(0, NULL); Return; } /* * tan(x), x in radians */FncDcl(tan,1) { int t; double y; if ((t = cvreal(&Arg1)) == CvtFail) RunErr(102, &Arg1); errno = 0; y = tan(BlkLoc(Arg1)->realblk.realval); if (errno == ERANGE) RunErr(-204, NULL); if (makereal(y, &Arg0) == Error) RunErr(0, NULL); Return; } /* * acos(x), x in radians */FncDcl(acos,1) { int t; double r, y; if ((t = cvreal(&Arg1)) == CvtFail) RunErr(102, &Arg1); r = BlkLoc(Arg1)->realblk.realval; if (r < -1.0 || r > 1.0) /* can't count on library */ RunErr(205,&Arg1); errno = 0; y = acos(r); if (errno == EDOM) RunErr(-205, NULL); if (makereal(y, &Arg0) == Error) RunErr(0, NULL); Return; } /* * asin(x), x in radians */FncDcl(asin,1) { int t; double r, y; if ((t = cvreal(&Arg1)) == CvtFail) RunErr(102, &Arg1); r = BlkLoc(Arg1)->realblk.realval; if (r < -1.0 || r > 1.0) /* can't count on library */ RunErr(205,&Arg1); errno = 0; y = asin(r); if (errno == EDOM) RunErr(-205, NULL); if (makereal(y, &Arg0) == Error) RunErr(0, NULL); Return; } /* * atan(x,y) -- x,y in radians; if y is present, produces atan2(x,y). */FncDcl(atan,2) { in if ((t = cvreal(&Arg1)) == CvtFail) RunErr(102, &Arg1); if (ChkNull(Arg2)) { if (makereal(atan(BlkLoc(Arg1)->realblk.realval), &Arg0) == Error) RunErr(0, NULL); } else { if ((t = cvreal(&Arg2)) == CvtFail) RunErr(102, &Arg2); if (makereal(atan2(BlkLoc(Arg1)->realblk.realval, BlkLoc(Arg2)->realblk.realval), &Arg0) == Error) RunErr(0, NULL); } Return; } /* * dtor(x), x in degrees */FncDcl(dtor,1) { if (cvreal(&Arg1) == CvtFail) RunErr(102, &Arg1); if (makereal(BlkLoc(Arg1)->realblk.realval * PI / 180, &Arg0) == Error) RunErr(0, NULL); Return; } /* * rtod(x), x in radians */FncDcl(rtod,1) { if (cvreal(&Arg1) == CvtFail) RunErr(102, &Arg1); if (makereal(BlkLoc(Arg1)->realblk.realval * 180 / PI, &Arg0) == Error) RunErr(0, NULL); Return; } /* * exp(x) */FncDcl(exp,1) { int t; double y; if ((t = cvreal(&Arg1)) == CvtFail) RunErr(102, &Arg1); errno = 0; y = exp(BlkLoc(Arg1)->realblk.realval); if (errno == ERANGE) RunErr(-204, NULL); if (makereal(y, &Arg0) == Error) RunErr(0, NULL); Return; } /* * log(x,b) - logarithm of x to base b. */FncDcl(log,2) { static double lastbase = 0.0; static double divisor; double x; if (cvreal(&Arg1) != T_Real) RunErr(102, &Arg1); if (BlkLoc(Arg1)->realblk.realval <= 0.0) RunErr(205, &Arg1); x = log(BlkLoc(Arg1)->realblk.realval); if (! ChkNull(Arg2)) { if (cvreal(&Arg2) != T_Real) RunErr(102, &Arg2); if (BlkLoc(Arg2)->realblk.realval <= 1.0) RunErr(205, &Arg2); if (BlkLoc(Arg2)->realblk.realval != lastbase) { divisor = log(BlkLoc(Arg2)->realblk.realval); lastbase = BlkLoc(Arg2)->realblk.realval; } x = x / divisor; } if (makereal(x, &Arg0) == Error) RunErr(0, NULL); Return; } /* * sqrt(x) */FncDcl(sqrt,1) { int t; double r, y; if ((t = cvreal(&Arg1)) == CvtFail) RunErr(102, &Arg1); r = BlkLoc(Arg1)->realblk.realval; if (r < 0) RunErr(205, &Arg1); y = sqrt(r); errno = 0; if (errno == EDOM) RunErr(-205, NULL); if (makereal(y, &Arg0) == Error) RunErr(0, NULL); Return; }#else /* MathFncs */static char x; /* prevent empty module */#endif /* MathFncs */ :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:fmemmon.c
/* * fxmemmon.c -- mmout, mmpause, mmshow, and internal functions. * * This file contains memory monitoring code. It is compiled by inclusion * in fxtra.c if MemMon is defined. When MemMon is undefined, most of the * "MMxxxx" entry points are defined as null macros in rt.h. */#include "::h:config.h"#include "::h:rt.h"#include "rproto.h"#ifdef PreProcess/* include(../M4/fncs.m4) /* *//* */#endif /* PreProcess */#ifdef MemMon/* * Prototypes. */hidden novalue mmcmd Params((word addr, word len, int c));hidden novalue mmdec Params((uword n));hidden novalue mmforget Params((noargs));hidden novalue mmlen Params((word n, int c));hidden novalue mmnewline Params((noargs));hidden novalue mmrefresh Params((noargs));hidden novalue mmsizes Params((int c));hidden novalue mmstatic Poargs));hidden novalue MMOut Params((char *prefix, char *msg));static FILE *monfile = NULL; /* output file pointer */static char *monname = NULL; /* output file name */static word llen = 0; /* current output line length */static char typech[MaxType+1]; /* output character for each type *//* Define size of curlength table, and bias needed to access it. *//* Assumes all type codes are printable characters (or space). *//* Smaller table is used if not EBCDIC. */#if !EBCDIC#define CurSize (127 - ' ')#define CurBias ' '#else /* !EBCDIC */#define CurSize 256#define CurBias 0#endif /* !EBCDIC */static word curlength[CurSize]; /* current length for each output character *//* line limit: start a new line when a command goes beyond this column */#define LLIM 70/* mmchar(c): output character c and update the column counter */#define mmchar(c) (llen++,putc((c),monfile))/* mmspace(): output unneeded whitespace whitespace following a command *//* define as "mmchar(' ')" for readable files, or as "0" for compact ones */#define mmspace() 0 /* * mmout(s) - write the given string to the MemMon file. */FncDcl(mmout,1) { char sbuf[MaxCvtLen]; int t; if ((t = defstr(&Arg1, sbuf, &emptystr)) == Error) RunErr(0, NULL); /* * Make sure Arg1 is a C-style string. */ if (t == NoCvt) qtos(&Arg1, sbuf); MMOut("", StrLoc(Arg1)); Arg0 = nulldesc; Return; } /* * mmpause(s) - pause MemMon displaying string s. */FncDcl(mmpause,1) { char sbuf[MaxCvtLen]; int t; if ((t = defstr(&Arg1, sbuf, &emptystr)) == Error) RunErr(0, NULL); if (StrLen(Arg1) == 0) MMOut("; ", "programmed pause"); else { /* * Make sure Arg1 is a C-style string. */ if (t == NoCvt) qtos(&Arg1, sbuf); MMOut("; ", StrLoc(Arg1)); } Arg0 = nulldesc; Return; } /* * mmshow(x, s) - alter MemMon display of x depending on s. */FncDcl(mmshow,2) { char sbuf[MaxCvtLen]; /* * Default Arg2 to the empty string and make sure it is a C-style string. */ switch (defstr(&Arg2, sbuf, &emptystr)) { case Cvt: /* Already converted to a C-style string */ break; case Defaulted: case NoCvt: qtos(&Arg2, sbuf); break; case Error: RunErr(0, NULL); } MMShow(&Arg1, StrLoc(Arg2)); Arg0 = nulldesc; Return; } /* * MMInit(filename) - initialization. * * Memory monitoring is activated if the environment variable MEMMON is * non-null. Its value names the output file; or, under Unix, a value * beginning with "|" specifies a command to which the output is piped. * * If MemMon is defined on a system lacking environment variables, * monitoring is always activated and output is to the file "memmon.out". */novalue MMInit(filename)char *filename; { int i; FILE *f; char time_buf[26];#ifdef EnvVars monname = getenv("MEMMON"); if (monname == NULL || strlen(monname) == 0) return;#else /* EnvVars */ monname = "memmon.out";#endif /* EnvVars */#if UNIX if (monname[0] == '|') f = popen(monname+1, "w"); else#endif /* UNIX */ f = fopen(monname, "w"); if (f == NULL) { fprintf(stderr, "MEMMON: cannot open %s\n", monname); fflush(stderr); exit(ErrorExit); } getctime(time_buf); fprintf(f, "## Icon MemMon output\n"); fprintf(f, "#\n"); fprintf(f, "# program: %s\n", filename); fprintf(f, "# date: %s\n", time_buf); for (i = 0; i <= MaxType; i++) typech[i] = '?'; /* initialize with error character */#ifdef LargeInts typech[T_Bignum] = 'i'; /* long integer */#endif /* LargeInts */ typech[T_Real] = 'r'; /* real number */ typech[T_Cset] = 'c'; /* cset */ typech[T_File] = 'f'; /* file block */ typech[T_Record] = 'R'; /* record block */ typech[T_Tvsubs] = 'u'; /* substring trapped variable */ typech[T_External]= 'E'; /* external block */ typech[T_List] = 'L'; /* list header block */ typech[T_Lelem] = 'l'; /* list element block */ typech[T_Table] = 'T'; /* table header block */ typech[T_Telem] = 't'; /* table element block */ typech[T_Tvtbl] = 'e'; /* table elem trapped variable*/ typech[T_Set] = 'S'; /* set header block */ typech[T_Selem] = 's'; /* set element block */ typech[T_Slots] = 'h'; /* set/table hash slots */ typech[T_Coexpr] = 'X'; /* co-expression block (static region) */ typech[T_Refresh] = 'x'; /* co-expression refresh block */ /* * codes used elsewhere but not shown here: * in the static region: 'A' = alien (malloc block), 'F' = free * in the string region: '"' = string */ /* * Set monfile to indicate that memmon is active. Don't set it earlier * than this, or we'll loop trying to trace the garbage collection that * creates the buffer space. */ monfile = f; mmrefresh(); /* show current state */ fflush(monfile); /* force it out */ } /* * MMTerm(part1, part2) - terminate memory monitoring. * part1 and part2 are concatentated to form an explanatory message. */novalue MMTerm(part1, part2)char *part1, *part2; { FILE *f; if (monfile == NULL) return; mmnewline(); mmsizes('='); /* make a final check on region sizes */ if (*part1 || *part2) /* if any reason given, write it as comment */ fprintf(monfile, "# %s%s\n", part1, part2); f = monfile; monfile = NULL; /* so we don't try to show the freeing of the buffer */#if UNIX if (monname[0] == '|') pclose(f); else#endif /* UNIX */ fclose(f); } /* * MMStat(a, n, c) - note static block at a, length n, represented by char 'c'. * Output values are in basic units (typically words). */novalue MMStat(a, n, c)char *a;word n;int c; {#ifndef FixedRegions if (monfile == NULL) return; mmcmd(DiffPtrs(a, statbase) / MMUnits, n / MMUnits, c);#endif /* FixedRegions */ }/* * MMAlc(len, type) - note an allocation at the end of the block region. */novalue MMAlc(len, type)word len;int type; { if (monfile == NULL) return; mmcmd((word)(-1), len / MMUnits, typech[type]); }/* * MMStr(len) - note a string allocation at the end of the string region. */novalue MMStr(slen)word slen; { if (monfile == NULL) return; mmcmd((word)(-1), slen, '"'); } /* * MMBGC() - begin garbage collection. */novalue MMBGC(region)int region; { if (monfile == NULL) return; mmsizes('='); /* write current sizes */ fprintf(monfile, "%d{\n", region); /* indicate start of g.c. */ fflush(monfile); mmforget(); /* clear memory of block sizes */ }/* * MMEGC() - end garbage collection. */novalue MMEGC() { if (monfile == NULL) return; mmnewline(); fprintf(monfile, "}\n"); /* indicate end of marking */ mmrefresh(); /* redraw regions after compaction */ fprintf(monfile, "!\n"); /* indicate end of g.c. */ fflush(monfile); } /* * MMMark(block, type) - mark indicated block during garbage collection. */novalue MMMark(block, type)char *block;int type; { if (monfile == NULL) return; mmcmd(DiffPtrs(block, blkbase) / MMUnits, (word)BlkSize(block) / MMUnits, typech[type]); }/* * MMSMark - Mark String. */novalue MMSMark(saddr, slen)char *saddr;word slen; { if (monfile == NULL) return; mmcmd(DiffPtrs(saddr, strbase), slen, '"'); } /* * MMOut(prefix, msg) - write the prefix and message to the MemMon output file. */static novalue MMOut(prefix, msg)char *prefix, *msg; { if (monfile == NULL) return; mmnewline(); fprintf(monfile, "%s%s\n", prefix, msg); } /* * MMShow(d, s) - redraw block indicated by descriptor d according to flags * in s. */novalue MMShow(d, s)dptr d;char *s; { char *block; uword addr; word len; char cmd, tch; if (monfile == NULL) return; if (Qual(*d)) { /* * Show a string. *//* if ((uword)StrLoc(*d)<(uword)strbase || (uword)StrLoc(*d)>=(uword)strend)*/ if (!InRange(strbase,StrLoc(*d),strend)) return; /* ignore if outside string region */ addr = DiffPtrs(StrLoc(*d), strbase); len = StrLen(*d); cmd = '$'; tch = '"'; } else if (Type(*d)==T_Coexpr) { /* * Show a coexpression block, which will be in the static region. */ block = (char *)BlkLoc(*d); addr = DiffPtrs(block, statbase) / MMUnits; len = BlkSize(block) / MMUnits; cmd = 'Y'; tch = typech[T_Coexpr]; } else if (Pointer(*d)) { /* * Show something in the block region. */ block = (char *)BlkLoc(*d);/* if ((uword)block < (uword)blkbase || (uword)block >= (uword)blkfree)*/ if (!InRange(blkbase,block,blkfree)) return; /* ignore if outside block region */ addr = DiffPtrs(block, blkbase) / MMUnits; len = BlkSize(block) / MMUnits; cmd = '%'; tch = typech[Type(*d)]; } mmdec(addr); /* address */ mmchar('+'); mmlen(len, cmd); /* length, and $ Y or % command */ if (s && *s) mmchar(*s); /* color flag from mmshow call */ else mmchar('r'); /* default color is 'r' (redraw) */ mmchar(tch); /* block type character */ if (llen >= LLIM) mmnewline(); else mmspace(); } /* * mmrefresh() - redraw screen, initially or after garbage collection. */static novalue mmrefresh() { char *p; word n; mmnewline(); mmsizes('<'); /* signal start of screen refresh */ mmnewline(); mmforget(); /* clear memory of past sizes */ mmstatic(); /* show the static region */ mmnewline(); for (p = blkbase; p < blkfree; p += n) MMAlc(n = BlkSize(p), (int)BlkType(p));/* block region */ mmnewline(); MMStr(DiffPtrs(strfree, strbase)); /* string region */ mmnewline(); fprintf(monfile, ">\n"); /* signal end of refresh */ mmsizes('='); /* confirm region sizes */ mmforget(); /* clear memory of past sizes */ }/* * mmstatic() - recap the static region (stack, coexprs, aliens, fr (this function is empty under FixedRegions) */static novalue mmstatic() {#ifndef FixedRegions HEADER *p; char *a; int h; word n; for (p = (HEADER *)statbase; (uword)p < (uword)(HEADER *)statfree; p += p->s.bsize) { a = (char *)(p + 1); n = (p->s.bsize - 1) * sizeof(HEADER); h = *(int *)a; if (h == T_Coexpr || a == (char *)stack) MMStat(a, n, 'X'); /* coexpression block */ else if (h == FREEMAGIC) MMStat(a, n, 'F'); /* free block */ else MMStat(a, n, 'A'); /* alien block */ } a = (char *)p; if (a < statend) MMStat(a, (word)(statend-a), 'F');/* rest of static region is free */#endif /* FixedRegions */ } /* * mmsizes(c) - output current region sizes, with initial character c. * If c is '<', the unit size is written ahead of it. */static novalue mmsizes(c)int c; { mmnewline(); if (c == '<') fprintf(monfile, "%d", MMUnits); fprintf(monfile, "%c %lu:%lu/%lu %lu:%lu/%lu %lu:%lu/%lu\n", c, /* static region; show as full, actual amount is unknown */ (unsigned long)statbase, (unsigned long)DiffPtrs(statend, statbase), (unsigned long)DiffPtrs(statend, statbase), /* string region */ (unsigned long)strbase, (unsigned long)DiffPtrs(strfree, strbase), (unsigned long)DiffPtrs(strend, strbase), /* block region */ (unsigned long)blkbase, (unsigned long)DiffPtrs(blkfree, blkbase), (unsigned long)DiffPtrs(blkend, blkbase)); } /* * mmcmd(addr, len, c) - output a memmon command. * If addr is < 0, it is omitted. * If len matches the previous value for command c, it is also omitted. * If the output fills the line, a following newline is written. */static novalue mmcmd(addr, len, c)word addr, len;int c; { if (addr >= 0) { mmdec((uword)addr); mmchar('+'); } mmlen(len, c); if (llen >= LLIM) mmnewline(); else mmspace(); }/* * mmlen(n, c) - output length n with character c. * Omit the length if it matches the previous value for c. */static novalue mmlen(n, c)word n;int c; { if (n != curlength[c-CurBias]) mmdec((uword)(curlength[c-CurBias] = n)); mmchar(c); }/* * mmdec(n) - output a decimal value, updating the line length. */static novalue mmdec (n)uword n; { if (n > 9) mmdec(n / 10); n %= 10; mmchar('0'+(int)n); } /* * mmnewline() - output a newline and reset the line length. */static novalue mmnewline() { if (llen > 0) { putc('\n', monfile); llen = 0; } }/* * mmforget() - clear the history of remembered lengths. */static novalue mmforget() { int c; for (c = 0; c < CurSize; c++) curlength[c] = -1; }#else /* MemMon */static char x; /* avoid empty module */#endif /* MemMon */ :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:fmisc.c
/* * File: fmisc.c * Contents: args, [callout], char, collect, copy, display, errorclear, iand, * icom, image, ior, ishift, ixor, ord, name, runerr, seq, sort, type, variable */#include <math.h>#include "::h:config.h"#include "::h:rt.h"#include "rproto.h"extern word coll_tot;extern word coll_stat;extern word coll_str;extern word coll_blk;struct dpair { struct descrip dr; struct descrip dv; };/* * Prototypes. */hidden int getname Params((dptr dp1, dptr dp2));hidden int trefcmp Params((dptr d1,dptr d2));hidden int tvalcmp Params((dptr d1,dptr d2));hidden int trcmp3 Params((struct dpair *dp1,struct dpair *dp2));hidden int tvcmp4 Params((struct dpair *dp1,struct dpair *dp2));/* * args(x) - produce number of arguments for procedure x. */FncDcl(args,1) { if (Arg1.dword != D_Proc) RunErr(106, &Arg1); MakeInt(((struct b_proc *)BlkLoc(Arg1))->nparam,&Arg0); Return; } #ifdef ExternalFunctions#ifdef IconCalling/* * callout - call a C routine with an argument count and a list of descriptors. */FncDclV(callout){ dptr retval; struct pf_marker *newpfp; register word *newsp = sp; int signal;/*------------------------------------------------------------------------*/ /* * Build a procedure frame. This is not normal for "built-in" procedures, * but we're preparing to call Icon back, if necessary. To get rid of * this frame, on the way out signal a Pret. The code between the dashed * lines is copied largely from invoke(). */ newpfp = (struct pf_marker *)(newsp + 1); newpfp->pf_nargs = nargs; newpfp->pf_argp = argp; newpfp->pf_pfp = pfp; newpfp->pf_ilevel = ilevel; newpfp->pf_scan = NULL; newpfp->pf_ipc = ipc; newpfp->pf_gfp = gfp; newpfp->pf_efp = efp; argp = cargp; /* cargp is newargp in invoke() */ pfp = newpfp; newsp += Vwsizeof(*pfp); efp = 0; gfp = 0; sp = newsp;/*------------------------------------------------------------------------*/ /* * Little cheat here. Although this is a var-arg procedure, we need * at least one argument to get started: pretend there is a null on * the stack. NOTE: Actually, at present, varargs functions always * have at least one argument, so this doesn't plug the hole. */ if (nargs < 1) RunErr(103, &nulldesc); /* * Call the 'C routine caller' with a pointer to an array of descriptors. * Note that these are being left on the stack. We are passing * the name of the routine as part of the convention of calling * routines with an argc/argv technique. */ signal = -1; /* presume successful completion */ retval = extcall(&Arg1, nargs, &signal); if (signal >= 0) { if (retval == NULL) RunErr(-signal, NULL) else RunErr(signal, retval); } if (retval != NULL) { Arg0 = *retval; return A_Pret_uw; } else return A_Pfail_uw; }#else /* IconCalling *//* * callout - call a C library routine (or any C routine which doesn't call Icon) * with an argument count and a list of descriptors. This routine * doesn't build a procedure frame to prepare for calling Icon back. */FncDclV(callout){ dptr retval; int signal; /* * Little cheat here. Although this is a var-arg procedure, we need * at least one argument to get started: pretend there is a null on * the stack. NOTE: Actually, at present, varargs functions always * have at least one argument, so this doesn't plug the hole. */ if (nargs < 1) RunErr(103, &nulldesc); /* * Call the 'C routine caller' with a pointer to an array of descriptors. * Note that these are being left on the stack. We are passing * the name of the routine as part of the convention of calling * routines with an argc/argv technique. */ signal = -1; /* presume successful completiong */ retval = extcall(&Arg1, nargs, &signal); if (signal >= 0) { if (retval == NULL) RunErr(-signal, NULL) else RunErr(signal, retval); } if (retval != NULL) { Arg0 = *retval; Return; } else Fail; }#endif /* IconCalling */#endif /* ExternalFunctions */ /* * char(i) - produce a string consisting of character i. */FncDcl(char,1) { char c; if (cvint(&Arg1) == CvtFail) RunErr(101, &Arg1); if (IntVal(Arg1) < 0 || IntVal(Arg1) >= 256) RunErr(205, &Arg1); if (strreq((uword)1) == Error) RunErr(0, NULL); c = IntVal(Arg1); StrLen(Arg0) = 1; StrLoc(Arg0) = alcstr(&FromAscii(c), (word)1); Return; } /* * collect(r,n) - call garbage collector to ensure n bytes in region r. */FncDcl(collect,2) { long region, bytes; word coll = coll_tot; if ((defint(&Arg1, ®ion, (word)0) == Error) || (defint(&Arg2, &bytes, (word)0) == Error)) RunErr(0, NULL); if (bytes < 0) RunErr(205, &Arg2); switch ((int)region) { case 0: break; case Static: coll_stat++; break; case Strings: coll_str++; if (strreq((uword)bytes) == Error) Fail; break; case Blocks: coll_blk++; if (blkreq((uword)bytes) == Error) Fail; break; default: RunErr(205, &Arg1); }; if (coll == coll_tot) collect((int)region); Arg0 = nulldesc; Return; } /* * copy(x) - make a copy of object x. */FncDcl(copy,1) { register int i; word slotnum; struct descrip *d1, *d2; struct b_slots *seg; register union block **tp, *ep, *bp, *op; if (Qual(Arg1)) /* * Arg1 is a string; just copy its descriptor * into Arg0. */ Arg0 = Arg1; else { switch (Type(Arg1)) { case T_Null: case T_Integer:#ifdef LargeInts case T_Bignum:#endif /* LargeInts */ case T_Real: case T_File: case T_Cset: case T_Proc: case T_Coexpr: case T_External: /* * Copy the null value, integers, long integers, reals, files, * csets, procedures, and such by copying the descriptor. * Note that for integers, this results in the assignment * of a value, for the other types, a pointer is directed to * a data block. */ Arg0 = Arg1; break; case T_List: /* * Pass the buck to cplist to copy a list. */ if (cplist(&Arg1, &Arg0, (word)1, BlkLoc(Arg1)->list.size + 1) == Error) RunErr(0, NULL); break; case T_Table: /* * Copy a Table. First, allocate and copy header and slot blocks. */ op = BlkLoc(Arg1); bp = hmake(T_Table, op->table.mask + 1, op->table.size); if (bp == NULL) RunErr(0, NULL); op = BlkLoc(Arg1); /* may have moved */ bp->table.size = op->table.size; bp->table.mask = op->table.mask; bp->table.defvalue = op->table.defvalue; for (i = 0; i < HSegs && op->table.hdir[i] != NULL; i++) memcopy((char *)bp->table.hdir[i], (char *)op->table.hdir[i], op->table.hdir[i]->blksize); /* * Work down the chain of element blocks in each bucket * and create identical chains in new table. */ for (i = 0; i < HSegs && (seg = bp->table.hdir[i]) != NULL; i++) for (slotnum = segsize[i] - 1; slotnum >= 0; slotnum tp = &seg->hslots[slotnum]; for (ep = *tp; ep != NULL; ep = *tp) { *tp = (union block *)alctelem(); (*tp)->telem = ep->telem; tp = &(*tp)->telem.clink; } } Arg0.dword = D_Table; BlkLoc(Arg0) = bp; if (TooSparse(bp)) hshrink(&Arg0); break; case T_Set: /* * Pass the buck to cpset to copy a set. */ if (cpset(&Arg1, &Arg0, BlkLoc(Arg1)->set.size) == Error) RunErr(0, NULL); break; case T_Record: /* * Allocate space for the new record and copy the old * one into it. */ if (blkreq(BlkLoc(Arg1)->record.blksize) == Error) RunErr(0, NULL); i = (int)BlkLoc(Arg1)->record.recdesc->proc.nfields; bp = (union block *)alcrecd(i,&BlkLoc(Arg1)->record.recdesc); bp->record = BlkLoc(Arg1)->record; bp->record.id = bp->record.recdesc->proc.recid++; /* get new id */ d1 = bp->record.fields; d2 = BlkLoc(Arg1)->record.fields; while (i--) *d1++ = *d2++; /* * Return the copied record */ Arg0.dword = D_Record; BlkLoc(Arg0) = bp; break; default: RunErr(123,&Arg1); } } Return; } /* * display(i,f) - display local variables of i most recent * procedure activations, plus global variables. * Output to file f (default &errout). */FncDcl(display,2) { long l; int count; FILE *f; /* * Arg1 defaults to &level; Arg2 defaults to &errout. */ if ((defint(&Arg1, &l, (word)k_level) == Error) || (deffile(&Arg2, &errout) == Error)) RunErr(0, NULL); /* * Produce error if file cannot be written. */ f = BlkLoc(Arg2)->file.fd; if ((BlkLoc(Arg2)->file.status & Fs_Write) == 0) RunErr(213, &Arg2); /* * Produce error if Arg1 is negative; constrain Arg1 to be >= &level. */ if (l < 0) { RunErr(205, &Arg1); } else if (l > k_level) count = k_level; else count = (int)l; fprintf(f,"co-expression_%ld(%ld)\n\n",BlkLoc(k_current)->coexpr.id, BlkLoc(k_current)->coexpr.size); fflush(f); xdisp(pfp,argp,count,f); Arg0 = nulldesc; /* Return null value. */ Return; } /* * errorclear() - clear error condition. */FncDcl(errorclear,0) { k_errornumber = 0; k_errortext = ""; k_errorvalue = nulldesc; Arg0 = nulldesc; Return; } /* * iand(i,j) - produce bitwise AND of i and j. */FncDcl(iand,2) {#ifdef LargeInts int t1, t2; if ((t1 = cvnum(&Arg1)) == CvtFail) RunErr(101, &Arg1); if ((t2 = cvnum(&Arg2)) == CvtFail) RunErr(101, &Arg2); if (t1 == T_Real) { if (realtobig(&Arg1, &Arg1) == Error) /* alcbignum failed */ RunErr(0, NULL); t1 = Type(Arg1); } if (t2 == T_Real) { if (realtobig(&Arg2, &Arg2) == Error) /* alcbignum failed */ RunErr(0, NULL);; t2 = Type(Arg2); } if (t1 == T_Integer && t2 == T_Integer) { MakeInt(IntVal(Arg1) & IntVal(Arg2), &Arg0); } else if (bigand(&Arg1, &Arg2, &Arg0) == Error) /* alcvignum failed */ RunErr(0, NULL);#else /* LargeInts */ if (cvint(&Arg1) == CvtFail) RunErr(101, &Arg1); if (cvint(&Arg2) == CvtFail) RunErr(101, &Arg2); MakeInt(IntVal(Arg1) & IntVal(Arg2), &Arg0);#endif /* LargeInts */ Return; } /* * icom(i) - produce bitwise complement (one's complement) of i. */FncDcl(icom,1) {#ifdef LargeInts int t1; if ((t1 = cvnum(&Arg1)) == CvtFail) RunErr(101, &Arg1); if (t1 == T_Real) { if (realtobig(&Arg1, &Arg1) == Error) /* alcbignum failed */ RunErr(0, NULL); t1 = Type(Arg1); } if (t1 == T_Integer) { MakeInt(~IntVal(Arg1), &Arg0); } else { struct descrip td; td.dword = D_Integer; IntVal(td) = -1; if (bigsub(&td, &Arg1, &Arg0) == Error) /* alcbignum failed */ RunErr(0, NULL); }#else /* LargeInts */ if (cvint(&Arg1) == CvtFail) RunErr(101, &Arg1); MakeInt(~IntVal(Arg1), &Arg0);#endif /* LargeInts */ Return; } /* * image(x) - return string image of object x. Nothing fancy here, * just plug and chug on a case-wise basis. */FncDcl(image,1) { if (getimage(&Arg1,&Arg0) == Error) RunErr(0, NULL); Return; } /* * ior(i,j) - produce bitwise inclusive OR of i and j. */FncDcl(ior,2) {#ifdef LargeInts int t1, t2; if ((t1 = cvnum(&Arg1)) == CvtFail) RunErr(101, &Arg1); if ((t2 = cvnum(&Arg2)) == CvtFail) RunErr(101, &Arg2); if (t1 == T_Real) { if (realtobig(&Arg1, &Arg1) == Error) /* alcbignum failed */ RunErr(0, NULL); t1 = Type(Arg1); } if (t2 == T_Real) { if (realtobig(&Arg2, &Arg2) == Error) /* alcbignum failed */ RunErr(0, NULL); t2 = Type(Arg2); } if (t1 == T_Integer && t2 == T_Integer) { MakeInt(IntVal(Arg1) | IntVal(Arg2), &Arg0); } else if (bigor(&Arg1, &Arg2, &Arg0) == Error) /* alcbignum failed */ RunErr(0, NULL);#else /* LargeInts */ if (cvint(&Arg1) == CvtFail) RunErr(101, &Arg1); if (cvint(&Arg2) == CvtFail) RunErr(101, &Arg2); MakeInt(IntVal(Arg1) | IntVal(Arg2), &Arg0);#endif /* LargeInts */ Return; } /* * ishift(i,j) - produce i shifted j bit positions (left if j<0, right if j>0). */FncDcl(ishift,2) { uword i; /* unsigned to ensure zero fill on right shift */ word n;#ifdef LargeInts int t1; if ((t1 = cvnum(&Arg1)) == CvtFail) RunErr(101, &Arg1); if (cvint(&Arg2) == CvtFail) RunErr(101, &Arg2); if (t1 == T_Real) { if (realtobig(&Arg1, &Arg1) == Error) /* alcbignum failed */ RunErr(0, NULL); t1 = Type(Arg1); } if (t1 == T_Bignum || IntVal(Arg2) > 0) { if (bigshift(&Arg1, &Arg2, &Arg0) == Error) /* alcbignum failed */ RunErr(0, NULL); Return; }#else /* LargeInts */ if (cvint(&Arg1) == CvtFail) RunErr(101, &Arg1); if (cvint(&Arg2) == CvtFail) RunErr(101, &Arg2);#endif /* LargeInts */ i = (uword)IntVal(Arg1); n = IntVal(Arg2); /* * Check for a shift of WordSize or greater; return an explicit 0 because * this is beyond C's defined behavior. Otherwise shift as requested. */ if (n <= -WordBits || n >= WordBits) i = 0; else if (n < 0) i >>= -n; else i <<= n; MakeInt(i, &Arg0); Return; } /* * ixor(i,j) - produce bitwise exclusive OR of i and j. */FncDcl(ixor,2) {#ifdef LargeInts int t1, t2; if ((t1 = cvnum(&Arg1)) == CvtFail) RunErr(101, &Arg1); if ((t2 = cvnum(&Arg2)) == CvtFail) RunErr(101, &Arg2); if (t1 == T_Real) { if (realtobig(&Arg1, &Arg1) == Error) /* alcbignum failed */ RunErr(0, NULL); t1 = Type(Arg1); } if (t2 == T_Real) { if (realtobig(&Arg2, &Arg2) == Error) /* alcbignum failed */ RunErr(0, NULL); t2 = Type(Arg2); } if (t1 == T_Integer && t2 == T_Integer) { MakeInt(IntVal(Arg1) ^ IntVal(Arg2), &Arg0); } else if (bigxor(&Arg1, &Arg2, &Arg0) == Error) /* alcbignum failed */ RunErr(0, NULL);#else /* LargeInts */ if (cvint(&Arg1) == CvtFail) RunErr(101, &Arg1); if (cvint(&Arg2) == CvtFail) RunErr(101, &Arg2); MakeInt(IntVal(Arg1) ^ IntVal(Arg2), &Arg0);#endif /* LargeInts */ Return; } /* * ord(s) - produce integer ordinal (value) of single chracter. */FncDcl(ord,1) { char sbuf[MaxCvtLen]; if (cvstr(&Arg1, sbuf) == CvtFail) RunErr(103, &Arg1); if (StrLen(Arg1) != 1) RunErr(205, &Arg1); MakeInt(ToAscii(*StrLoc(Arg1) & 0xFF), &Arg0); Return; } FncNDcl(name,1) { if (!Var(Arg1)) RunErr(
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:fmisc.
+++++ Continued from previous card +++++
111, &Arg1); if (getname(&Arg1, &Arg0) == Error) RunErr(0,NULL); Return; } /* * getname -- function to get print name of variable */static int getname(dp1,dp0) dptr dp1, dp0; { dptr dp, varptr; union block *blkptr; char sbuf[100]; /* buffer; might be too small */ word i, j, k; extern word *ftabp, *records; word *rp; extern dptr fnames; /* * Is it a trapped variable? */ if Tvar(*dp1) { blkptr = BlkLoc(*dp1); switch (Type(*dp1)) { case T_Tvkywd: *dp0 = BlkLoc(*dp1)->tvkywd.kyname; return Success; case T_Tvsubs: getname(&(blkptr->tvsubs.ssvar),dp0); sprintf(sbuf,"[%ld:%ld]",blkptr->tvsubs.sspos, blkptr->tvsubs.sslen); j = strlen(sbuf); k = StrLen(*dp0); if (strreq(j + k) == Error) return Error; StrLoc(*dp0) = alcstr(StrLoc(*dp0),k); alcstr(sbuf,j); StrLen(*dp0) = j + k; return Success; case T_Tvtbl: return keyref(dp1,dp0); default: { syserr("name: invalid trapped variable"); } } } /* * Not a trapped variable; is it an identifier? */ dp = VarLoc(*dp1); /* get address of variable */ if (globals <= dp && dp < eglobals) { *dp0 = gnames[dp - globals]; /* global */ return Success; } else if (statics <= dp && dp < estatics) { blkptr = BlkLoc(*argp); i = dp - statics - blkptr->proc.fstatic; /* static */ if (i < 0 || i >= blkptr->proc.nstatic) syserr("name: unreferencable static variable"); i += abs(blkptr->proc.nparam) + abs(blkptr->proc.ndynam); *dp0 = blkptr->proc.lnames[i]; return Success; } else if (stack < (word *)dp && (word *)dp <= sp) { if ((struct pf_marker*)dp < pfp) { /* argument */ *dp0 = ((struct b_proc *)VarLoc(*argp))->lnames[(dp - argp) - 1]; } else { /* local */ *dp0 = ((struct b_proc *)VarLoc(*argp))->lnames[dp - pfp->pf_locals + ((struct b_proc *)VarLoc(*argp))->nparam]; } return Success; } /* * Must be an element of a structure. */ blkptr = (union block *)VarLoc(*dp1); varptr = (dptr)((word *)VarLoc(*dp1) + Offset(*dp1)); switch ((int)BlkType(blkptr)) { case T_Lelem: { /* list */ if ((i = varptr - &blkptr->lelem.lslots[blkptr->lelem.first] + 1) < 1) i += blkptr->lelem.nslots; while (blkptr->lelem.listprev != NULL) { blkptr = blkptr->lelem.listprev; i += blkptr->lelem.nused; } sprintf(sbuf,"L[%ld]",i); i = strlen(sbuf); if (strreq(i) == Error) return Error; StrLoc(*dp0) = alcstr(sbuf,i); StrLen(*dp0) = i; return Success; } case T_Record: { /* record */ i = varptr - blkptr->record.fields; rp = records + 1; j = blkptr->record.recdesc->proc.recnum - 1; k = 0; while (ftabp[j] != i) { j += *records; k++; } sprintf(sbuf,"%s.%s",StrLoc(blkptr->record.recdesc-> proc.recname),StrLoc(fnames[k])); i = strlen(sbuf); if (strreq(i) == Error) return Error; StrLoc(*dp0) = alcstr(sbuf,i); StrLen(*dp0) = i; return Success; } case T_Telem: { /* table */ return keyref(dp1,dp0); } default: /* none of the above */ syserr("name: invalid structure reference"); } } /* * keyref(bp,dp) -- print name of subscripted table */int keyref(dp1, dp2) dptr dp1, dp2; { char *s; dp1 = &(((union block *)BlkLoc(*dp1))->telem.tref); if (getimage(dp1,dp2) == Error) return Error; if (strreq(StrLen(*dp2) + 3) == Error) return Error; s = alcstr("T[",(word)2); alcstr(StrLoc(*dp2),StrLen(*dp2)); alcstr("]",(word)1); StrLoc(*dp2) = s; StrLen(*dp2) = StrLen(*dp2) + 3; return Success; } /* * runerr(i,x) - produce runtime error i with value x. */FncDclV(runerr) { if (nargs < 1) RunErr(-101, NULL); switch (cvint(&Arg1)) { case T_Integer: if (IntVal(Arg1) <= 0) RunErr(205, &Arg1); break; default: RunErr(101, &Arg1); } if (nargs == 1) { RunErr((int)(-IntVal(Arg1)), NULL); } else { RunErr((int)IntVal(Arg1), &Arg2); } } /* * seq(e1,e2) - generate e1, e1+e2, e1+e2+e2, ... . */FncDcl(seq,2) { long from, by; /* * Default Arg1 and Arg2 to 1. */ if ((defint(&Arg1, &from, (word)1) == Error) || (defint(&Arg2, &by, (word)1) == Error)) RunErr(0, NULL); /* * Produce error if Arg2 is 0, i.e., an infinite sequence of Arg2s. */ if (by == 0) RunErr(211, &Arg2); /* * Suspend sequence, stopping when largest or smallest integer * is reached. */ while ((from <= MaxLong && by > 0) || (from >= MinLong && by < 0)) { MakeInt(from, &Arg0); Suspend; from += by; } Fail; } /* * sort(l) - sort list l. * sort(S) - sort set S. * sort(t,i) - sort table. */FncDcl(sort,2) { register dptr d1; register word size, i, j; register struct b_slots *seg; word nslots; struct b_list *lp, *tp; union block *bp, *ep; if (Arg1.dword == D_List) { /* * Sort the list by copying it into a new list and then using * qsort to sort the descriptors. (That was easy!) */ size = BlkLoc(Arg1)->list.size; if (cplist(&Arg1, &Arg0, (word)1, size + 1) == Error) RunErr(0, NULL); qsort((char *)BlkLoc(Arg0)->list.listhead->lelem.lslots, (int)size, sizeof(struct descrip), anycmp); } else if (Arg1.dword == D_Set) { /* * Create a list the size of the set, copy each element into the list, and * then sort the list using qsort as in list sorting and return the * sorted list. */ nslots = size = BlkLoc(Arg1)->set.size; if (blkreq(sizeof(struct b_list) + sizeof(struct b_lelem) + nslots * sizeof(struct descrip)) == Error) RunErr(0, NULL); bp = BlkLoc(Arg1); lp = alclist(size); lp->listtail = (union block *)alclstb(nslots, (word)0, size); lp->listhead = lp->listtail; if (size > 0) { /* only need to sort non-empty sets */ d1 = lp->listhead->lelem.lslots; for (i = 0; i < HSegs && (seg = bp->table.hdir[i]) != NULL; i++) for (j = segsize[i] - 1; j >= 0; j--) for (ep = seg->hslots[j]; ep != NULL; ep = ep->telem.clink) *d1++ = ep->selem.setmem; qsort((char *)lp->listhead->lelem.lslots,(int)size, sizeof(struct descrip),anycmp); } Arg0.dword = D_List; BlkLoc(Arg0) = (union block *) lp; } else if (Arg1.dword == D_Table) { /* * Default i (the type of sort) to 1. */ if (defshort(&Arg2, 1) == Error) RunErr(0, NULL); switch ((int)IntVal(Arg2)) { /* * Cases 1 and 2 are as in standard Version 5. */ case 1: case 2: { /* * The list resulting from the sort will have as many elements as * the table has, so get that value and also make a valid list * block size out of it. */ nslots = size = BlkLoc(Arg1)->table.size; /* * Ensure space for: the list header block and a list element * block for the list which is to be returned, * a list header block and a list element block for each of the two * element lists the sorted list is to contain. Note that the * calculation might be better expressed as: * list_header_size + list_block_size + nslots * descriptor_size + * nslots * (list_header_size + list_block_size + 2*descriptor_size) */ if (blkreq(sizeof(struct b_list) + sizeof(struct b_lelem) + nslots * (sizeof(struct b_list) + sizeof(struct b_lelem) + 3 * sizeof(struct descrip))) == Error) RunErr(0, NULL); /* * Point bp at the table header block of the table to be sorted * and point lp at a newly allocated list * that will hold the the result of sorting the table. */ bp = BlkLoc(Arg1); lp = alclist(size); lp->listtail = (union block *)alclstb(nslots, (word)0, size); lp->listhead = lp->listtail; /* * If the table is empty, there is no need to sort anything. */ if (size <= 0) break; /* * Point d1 at the start of the list elements in the new list * element block in preparation for use as an index into the list. */ d1 = lp->listhead->lelem.lslots; /* * Traverse the element chain for each table bucket. For each * element, allocate a two-element list and put the table * entry value in the first element and the assigned value in * the second element. The two-element list is assigned to * the descriptor that d1 points at. When this is done, the * list of two-element lists is complete, but unsorted. */ for (i = 0; i < HSegs && (seg = bp->table.hdir[i]) != NULL; i++) for (j = segsize[i] - 1; j >= 0; j--) for (ep = seg->hslots[j]; ep != NULL; ep = ep->telem.clink) { d1->dword = D_List; tp = alclist((word)2); BlkLoc(*d1) = (union block *)tp; tp->listtail = (union block *)alclstb((word)2, (word)0, (word)2); tp->listhead = tp->listtail; tp->listhead->lelem.lslots[0] = ep->telem.tref; tp->listhead->lelem.lslots[1] = ep->telem.tval; d1++; } /* * Sort the resulting two-element list using the sorting function * determined by i. */ if (IntVal(Arg2) == 1) qsort((char *)lp->listhead->lelem.lslots, (int)size, sizeof(struct descrip), trefcmp); else qsort((char *)lp->listhead->lelem.lslots, (int)size, sizeof(struct descrip), tvalcmp); break; /* from cases 1 and 2 */ } /* * Cases 3 and 4 were introduced in Version 5.10. */ case 3 : case 4 : { /* * The list resulting from the sort will have twice as many elements as * the table has, so get that value and also make a valid list * block size out of it. */ nslots = size = BlkLoc(Arg1)->table.size * 2; /* * Ensure space for: the list header block and a list element * block for the list which is to be returned, and two descriptors for * each table element. */ if (blkreq(sizeof(struct b_list) + Vsizeof(struct b_lelem) + (nslots * sizeof(struct descrip))) == Error) RunErr(0, NULL); /* * Point bp at the table header block of the table to be sorted * and point lp at a newly allocated list * that will hold the the result of sorting the table. */ bp = BlkLoc(Arg1); lp = alclist(size); lp->listtail = (union block *)alclstb(nslots, (word)0, size); lp->listhead = lp->listtail; /* * If the table is empty there's no need to sort anything. */ if (size <= 0) break; /* * Point d1 at the start of the list elements in the new list * element block in preparation for use as an index into the list. */ d1 = lp->listhead->lelem.lslots; /* * Traverse the element chain for each table bucket. For each * table element copy the the entry descriptor and the value * descriptor into adjacent descriptors in the lslots array * in the list element block. * When this is done we now need to sort this list. */ for (i = 0; i < HSegs && (seg = bp->table.hdir[i]) != NULL; i++) for (j = segsize[i] - 1; j >= 0; j--) for (ep = seg->hslots[j]; ep != NULL; ep = ep->telem.clink) { *d1++ = ep->telem.tref; *d1++ = ep->telem.tval; } /* * Sort the resulting two-element list using the sorting function * determined by i. */ if (IntVal(Arg2) == 3) qsort((char *)lp->listhead->lelem.lslots, (int)size / 2, (2 * sizeof(struct descrip)), trcmp3); else qsort((char *)lp->listhead->lelem.lslots, (int)size / 2, (2 * sizeof(struct descrip)), tvcmp4); break; /* from case 3 or 4 */ } default: RunErr(205, &Arg2); } /* end of switch statement */ /* * Make Arg0 point at the sorted list. */ Arg0.dword = D_List; BlkLoc(Arg0) = (union block *) lp; } else { /* Tried to sort something that wasn't a list or a table. */ RunErr(115, &Arg1); } Return; }/* * trefcmp(d1,d2) - compare two-element lists on first field. */static int trefcmp(d1, d2)dptr d1, d2; {#ifdef DeBugIconx if (d1->dword != D_List || d2->dword != D_List) syserr("trefcmp: internal consistency check fails.");#endif /* DeBugIconx */ return (anycmp(&(BlkLoc(*d1)->list.listhead->lelem.lslots[0]), &(BlkLoc(*d2)->list.listhead->lelem.lslots[0]))); }/* * tvalcmp(d1,d2) - compare two-element lists on second field. */static int tvalcmp(d1, d2)dptr d1, d2; {#ifdef DeBugIconx if (d1->dword != D_List || d2->dword != D_List) syserr("tvalcmp: internal consistency check fails.");#endif /* DeBugIconx */ return (anycmp(&(BlkLoc(*d1)->list.listhead->lelem.lslots[1]), &(BlkLoc(*d2)->list.listhead->lelem.lslots[1]))); }/* * The following two routines are used to compare descriptor pairs in the * experimental table sort. * * trcmp3(dp1,dp2) */static int trcmp3(dp1, dp2)struct dpair *dp1,*dp2;{ return (anycmp(&((*dp1).dr),&((*dp2).dr)));}/* * tvcmp4(dp1,dp2) */static int tvcmp4(dp1, dp2)struct dpair *dp1,*dp2; { return (anycmp(&((*dp1).dv),&((*dp2).dv))); } /* * type(x) - return type of x as a string. */FncDcl(type,1) { if (Qual(Arg1)) { StrLen(Arg0) = 6; StrLoc(Arg0) = "string"; } else { switch (Type(Arg1)) { case T_Null: StrLen(Arg0) = 4; StrLoc(Arg0) = "null"; break;#ifdef LargeInts case T_Bignum:#endif /* LargeInts */ case T_Integer: StrLen(Arg0) = 7; StrLoc(Arg0) = "integer"; break; case T_Real: StrLen(Arg0) = 4; StrLoc(Arg0) = "real"; break; case T_Cset: StrLen(Arg0) = 4; StrLoc(Arg0) = "cset"; break; case T_File: StrLen(Arg0) = 4; StrLoc(Arg0) = "file"; break; case T_Proc: StrLen(Arg0) = 9; StrLoc(Arg0) = "procedure"; break; case T_List: StrLen(Arg0) = 4; StrLoc(Arg0) = "list"; break; case T_Table: StrLen(Arg0) = 5; StrLoc(Arg0) = "table"; break; case T_Set: StrLen(Arg0) = 3; StrLoc(Arg0) = "set"; break; case T_Record:
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:fmisc.
+++++ Continued from previous card +++++
Arg0 = BlkLoc(Arg1)->record.recdesc->proc.recname; break; case T_Coexpr: StrLen(Arg0) = 13; StrLoc(Arg0) = "co-expression"; break; case T_External: StrLen(Arg0) = 8; StrLoc(Arg0) = "external"; break; default: RunErr(123,&Arg1); } } Return; } /* * variable(s) - find the variable with name s and return a * variable descriptor which points to its value. */FncDcl(variable,1) { char sbuf[MaxCvtLen]; switch (cvstr(&Arg1, sbuf)) { case Cvt: /* Already converted to a C-style string */ break; case NoCvt: qtos(&Arg1, sbuf); break; default: RunErr(103, &Arg1); } if (getvar(StrLoc(Arg1),&Arg0) == Success) Return; else Fail; } :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:fscan.c
/* * File: fscan.c * Contents: move, pos, tab. */#include "::h:config.h"#include "::h:rt.h"#include "rproto.h"#ifdef PreProcess/* include(../M4/fncs.m4) /* *//* */#endif /* PreProcess *//* * move(i) - move &pos by i, return substring of &subject spanned. * Reverses effects if resumed. */FncDcl(move,1) { register word i, j; word oldpos; /* * Arg1 must be a (non-long) integer. */ switch (cvint(&Arg1)) { case T_Integer: j = (word)IntVal(Arg1); break; default: RunErr(101, &Arg1); } /* * Save old &pos. Local variable i holds &pos before the move. */ oldpos = i = k_pos; /* * If attempted move is past either end of the string, fail. */ if (i + j <= 0 || i + j > StrLen(k_subject) + 1) Fail; /* * Set new &pos. */ k_pos += j; /* * Make sure j >= 0. */ if (j < 0) { i += j; j = -j; } /* * Suspend substring of &subject that was moved over. */ StrLen(Arg0) = j; StrLoc(Arg0) = StrLoc(k_subject) + i - 1; Suspend; /* * If move is resumed, restore the old position and fail. */ if (oldpos > StrLen(k_subject) + 1) { RunErr(205, &tvky_pos.kyval) } else k_pos = oldpos; Fail; } /* * pos(i) - test if &pos is at position i in &subject. */FncDcl(pos,1) { register word i; /* * Arg1 must be an integer. */ if (cvint(&Arg1) == CvtFail) RunErr(101, &Arg1); /* * Fail if &pos is not equivalent to Arg1, return Arg1 otherwise. */ if ((i = cvpos(IntVal(Arg1), StrLen(k_subject))) != k_pos) Fail; MakeInt(i, &Arg0); Return; } /* * tab(i) - set &pos to i, return substring of &subject spanned. * Reverses effects if resumed.. */FncDcl(tab,1) { register word i, j; word t, oldpos; /* * Arg1 must be an integer. */ if (cvint(&Arg1) == CvtFail) RunErr(101, &Arg1); /* * Convert it to an absolute position. */ j = cvpos(IntVal(Arg1), StrLen(k_subject)); if (j == CvtFail) Fail; /* * Save old &pos. Local variable i holds &pos before the tab. */ oldpos = i = k_pos; /* * Set new &pos. */ k_pos = j; /* * Make j the length of the substring &subject[i:j] */ if (i > j) { t = i; i = j; j = t - j; } else j = j - i; /* * Suspend the portion of &subject that was tabbed over. */ StrLoc(Arg0) = StrLoc(k_subject) + i - 1; StrLen(Arg0) = j; Suspend; /* * If tab is resumed, restore the old position and fail. */ if (oldpos > StrLen(k_subject) + 1) { RunErr(205, &tvky_pos.kyval); } else k_pos = oldpos; Fail; } :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:fstr.c
/* * File: fstr.c * Contents: center, detab, entab, left, map, repl, reverse, right, trim */#include "::h:config.h"#include "::h:rt.h"#include "rproto.h"#include <ctype.h>/* * Prototype. */hidden int nxttab Params((int col));#ifdef PreProcess/* include(../M4/fncs.m4) /* *//* */#endif /* PreProcess *//* * center(s1,n,s2) - pad s1 on left and right with s2 to length n. */FncDcl(center,3) { register char *s, *st; word cnt, slen, hcnt; char *sbuf, *s3; char sbuf1[MaxCvtLen], sbuf2[MaxCvtLen]; /* * Arg1 must be a string. Arg2 must be a non-negative integer and defaults * to 1. Arg3 must be a string and defaults to a blank. */ if (cvstr(&Arg1, sbuf1) == CvtFail) RunErr(103, &Arg1); if (defshort(&Arg2, 1) == Error) RunErr(0, NULL); if ((cnt = IntVal(Arg2)) < 0) RunErr(205, &Arg2); if (defstr(&Arg3, sbuf2, &blank) == Error) RunErr(0, NULL); if (strreq(cnt) == Error) RunErr(0, NULL); if (StrLen(Arg3) == 0) { /* * The padding string is null; make it a blank. */ slen = 1; s3 = " "; } else { slen = StrLen(Arg3); s3 = StrLoc(Arg3); } /* * Get space for the new string. Start at the right * of the new string and copy Arg3 into it from right to left as * many times as will fit in the right half of the new string. */ sbuf = alcstr(NULL, cnt); hcnt = cnt / 2; s = sbuf + cnt; while (s > sbuf + hcnt) { st = s3 + slen; while (st > s3 && s > sbuf + hcnt) *--s = *--st; } /* * Start at the left end of the new string and copy Arg1 into it from * left to right as many time as will fit in the left half of the * new string. */ s = sbuf; while (s < sbuf + hcnt) { st = s3; while (st < s3 + slen && s < sbuf + hcnt) *s++ = *st++; } slen = StrLen(Arg1); if (cnt < slen) { /* * Arg1 is larger than the field to center it in. The source for the * copy starts at the appropriate point in Arg1 and the destination * starts at the left end of of the new string. */ s = sbuf; st = StrLoc(Arg1) + slen/2 - hcnt + (~cnt&slen&1); } else { /* * Arg1 is smaller than the field to center it in. The source for the * copy starts at the left end of Arg1 and the destination starts at * the appropriate point in the new string. */ s = sbuf + hcnt - slen/2 - (~cnt&slen&1); st = StrLoc(Arg1); } /* * Perform the copy, moving min(*Arg1,Arg2) bytes from st to s. */ if (slen > cnt) slen = cnt; while (slen-- > 0) *s++ = *st++; /* * Return the new string. */ StrLen(Arg0) = cnt; StrLoc(Arg0) = sbuf; Return; } /* * detab(s,i,...) - replace tabs with spaces, with stops at columns indicated. */FncDclV(detab) { int i, last, interval, cnt, col, target; char *in, *out, *iend, c, sbuf1[MaxCvtLen]; float expan, etmp; /* * Arg1 is required and must be a string. * Additional args must be strictly increasing positive integers. * Calculate maximum expansion factor while checking. */ if (nargs < 1) RunErr(103, &nulldesc); if (cvstr(&Arg(1), sbuf1) == CvtFail) Ru, &Arg(1)); last = 1; if (nargs < 2) { interval = 8; expan = 8.0; } else { expan = 1.0; for (i = 2; i <= nargs; i++) { if (ArgType(i) != D_Integer) { if (cvint(&Arg(i)) != T_Integer) { RunErr(101, &Arg(i)); } } interval = ArgVal(i) - last; if (interval <= 0) RunErr(210, &Arg(i)); etmp = (float) (ArgVal(i) - 1) / (float) (i - 1); if (etmp > expan) expan = etmp; last = (int)ArgVal(i); } last -= interval; if (interval > expan) expan = interval; } /* * Get memory for worst case expansion. This would be a string of all tabs, * or repeated newlines after tabbing past a large tab interval. */ cnt = expan * StrLen(Arg1) + 1; if (strreq((word)cnt) == Error) RunErr(0, NULL); if (strfree + cnt > strend) syserr("detab allocation botch"); /* * Copy the string, expanding tabs. */ col = 1; target = 0; iend = StrLoc(Arg(1)) + StrLen(Arg(1)); for (in = StrLoc(Arg(1)), out = (char *)strfree; in < iend; ) switch (c = *out++ = *in++) { case '\b': col--; break; case LineFeed: case CarriageReturn: col = 1; break; case '\t': out--; if (col >= last) target = col + interval - (col - last) % interval; else { for (i = 2; col >= ArgVal(i); i++) ; target = (int)ArgVal(i); } while (col < target) { *out++ = ' '; col++; } break; default: if (isprint(c)) col++; } /* * Return new string if indeed there were tabs; otherwise return original * string to conserve memory. */ i = DiffPtrs(out, strfree); if (i > cnt) syserr("overenthusiastic tab expansion"); if (target > 0) { StrLen(Arg0) = i; /* set string length */ StrLoc(Arg0) = alcstr(NULL, (word)i); /* allocate the space we just filled */ } else Arg0 = Arg1; /* don't allocate, reuse old string */ Return; } /* * entab(s,i,...) - replace spaces with tabs, with stops at columns indicated. *//* temps for communication with nxttab(), following entab() */static dptr tablist; /* explicit tab stops (descriptors of ints) */static int last, interval; /* last explicit stop, and repeat interval */FncDclV(entab) { int i, target; char *in, *out, *iend, c, sbuf1[MaxCvtLen]; long col, cnt; /* * Arg1 is required and must be a string. * Additional args must be strictly increasing positive integers. */ if (nargs < 1) RunErr(103, &nulldesc); if (cvstr(&Arg(1), sbuf1) == CvtFail) RunErr(103, &Arg(1)); last = 1; interval = 8; for (i = 2; i <= nargs; i++) { if (ArgType(i) != D_Integer) { if (cvint(&Arg(i)) != T_Integer) { RunErr(101, &Arg(i)); } } interval = ArgVal(i) - last; if (interval <= 0) RunErr(210, &Arg(i)); last = (int)ArgVal(i); } if (last > 1) last -= interval; tablist = &Arg(2); /* if there is no arg 2, this won't be used, so ok */ /* * Get memory for result at end of string space. We may give some back * if not all needed, or all of it if no tabs can be inserted. */ cnt = StrLen(Arg1); if (strreq((word)cnt) == Error) RunErr(0, NULL); if (strfree + cnt > strend) syserr("entab allocation botch"); /* * Copy the string, looking for runs of spaces. */ col = 1; target = 0; iend = StrLoc(Arg(1)) + StrLen(Arg(1)); for (in = StrLoc(Arg(1)), out = (char *)strfree; in < iend; ) switch (c = *out++ = *in++) { case '\b': col--; break; case LineFeed: case CarriageReturn: col = 1; break; case '\t': if (col >= last) col += interval - (col - last) % interval; else { for (i = 2; col >= ArgVal(i); i++) ; col = ArgVal(i); } break; case ' ': target = col + 1; while (in < iend && *in == ' ') target++, in++; cnt = target - col; if (cnt > 1) { /* never tab just 1; already copied space */ if (nxttab(col) == col+1 && nxttab(col+1) > target) col++; /* keep space to avoid 1-col tab then spaces */ else out--; /* back up to begin tabbing */ while ((i = nxttab(col)) <= target) { *out++ = '\t'; /* put tabs to tab positions */ col = i; } while (col++ < target) *out++ = ' '; /* complete gap with spaces */ } col = target; break; default: if (isprint(c)) col++; } /* * Return new string if indeed there were tabs; otherwise return original * string to conserve memory. */ if (out > strend) syserr("entab allocation botch"); if (target) { /* if we did indeed insert tabs */ cnt = DiffPtrs(out, strfree); StrLen(Arg0) = cnt; /* set string length */ StrLoc(Arg0) = alcstr(NULL, cnt); /* allocate the space we just filled */ } else Arg0 = Arg1; /* don't allocate, return old string */ Return; } /* nxttab(col) -- helper routine for entab, returns next tab beyond col */static int nxttab(col)int col;{ dptr dp; long n; if (col >= last) return col + interval - (col - last) % interval; dp = tablist; while ((n = IntVal(*dp)) <= col) dp++; return n;} /* * left(s1,n,s2) - pad s1 on right with s2 to length n. */FncDcl(left,3) { register char *s, *st; word cnt, slen; char *sbuf, *s3, sbuf1[MaxCvtLen], sbuf2[MaxCvtLen]; /* * Arg1 must be a string. Arg2 must be a non-negative integer and defaults * to 1. Arg3 must be a string and defaults to a blank. */ if (cvstr(&Arg1, sbuf1) == CvtFail) RunErr(103, &Arg1); if (defshort(&Arg2, 1) == Error) RunErr(0, NULL); if ((cnt = IntVal(Arg2)) < 0) RunErr(205, &Arg2); if (defstr(&Arg3, sbuf2, &blank) == Error) RunErr(0, NULL); if (strreq(cnt) == Error) RunErr(0, NULL); if (StrLen(Arg3) == 0) { /* * The padding string is null; make it a blank. */ slen = 1; s3 = " "; } else { slen = StrLen(Arg3); s3 = StrLoc(Arg3); } /* * Get Arg2 bytes of string space. Start at the right end of the new * string and copy Arg3 into the new string as many times as it fits. * Note that Arg3 is copied from right to left. */ sbuf = alcstr(NULL, cnt); s = sbuf + cnt; while (s > sbuf) { st = s3 + slen; while (st > s3 && s > sbuf) *--s = *--st; } /* * Copy Arg1 into the new string, starting at the left end. * If *Arg1 > Arg2, only copy Arg2 bytes. */ s = sbuf; slen = StrLen(Arg1); st = StrLoc(Arg1); if (slen > cnt) slen = cnt; while (slen-- > 0) *s++ = *st++; /* * Return the new string. */ StrLen(Arg0) = cnt; StrLoc(Arg0) = sbuf; Return; } /* * map(s1,s2,s3) - map s1, using s2 and s3. */FncDcl(map,3) { register int i; register word slen; register char *s1, *s2, *s3; char sbuf1[MaxCvtLen], sbuf2[MaxCvtLen], sbuf3[MaxCvtLen]; static char maptab[256]; /* * Arg1 must be a string; Arg2 and Arg3 default to &ucase and &lcase, * respectively. */ if (cvstr(&Arg1, sbuf1) == CvtFail) RunErr(103, &Arg1); if (ChkNull(Arg2)) Arg2 = ucase; if (ChkNull(Arg3)) Arg3 = lcase; /* * If Arg2 and Arg3 are the same as for the last call of map, * the current values in maptab can be used. Otherwise, the * mapping information must be recomputed. */ if (!EqlDesc(maps2,Arg2) || !EqlDesc(maps3,Arg3)) { maps2 = Arg2; maps3 = Arg3; /* * Convert Arg2 and Arg3 to strings. They must be of the * same length. */ if (cvstr(&Arg2, sbuf2) == CvtFail) RunErr(103, &Arg2); if (cvstr(&Arg3, sbuf3) == CvtFail) RunErr(103, &Arg3); if (StrLen(Arg2) != StrLen(Arg3)) RunErr(-208, NULL); /* * The array maptab is used to perform the mapping. First, * maptab[i] is initialized with i for i from 0 to 255. * Then, for each character in Arg2, the position in maptab * corresponding to the value of the character is assigned * the value of the character in Arg3 that is in the same * position as the character from Arg2. */ s2 = StrLoc(Arg2); s3 = StrLoc(Arg3); for (i = 0; i <= 255; i++) maptab[i] = i; for (slen = 0; slen < StrLen(Arg2); slen++) maptab[s2[slen]&0377] = s3[slen]; } if (StrLen(Arg1) == 0) { Arg0 = emptystr; Return; } /* * The result is a string the size of Arg1; ensure that much space. */ slen = StrLen(Arg1); if (strreq(slen) == Error) RunErr(0, NULL); s1 = StrLoc(Arg1); /* * Create the result string, but specify no value for it. */ StrLen(Arg0) = slen; StrLoc(Arg0) = alcstr(NULL, slen); s2 = StrLoc(Arg0); /* * Run through the string, using values in maptab to do the * mapping. */ while (slen-- > 0) *s2++ = maptab[(*s1++)&0377]; Return; } /* * repl(s,n) - concatenate n copies of string s. */FncDcl(repl,2) { register char *sloc; register int cnt; char sbuf[MaxCvtLen]; /* * Make sure that Arg1 is a string. */ if (cvstr(&Arg1, sbuf) == CvtFail) RunErr(103, &Arg1); /* * Make sure that Arg2 is an integer. */ switch (cvint(&Arg2)) { /* * Make sure count is not negative. */ case T_Integer: if ((cnt = (int)IntVal(Arg2)) >= 0) break; RunErr(205, &Arg2); default: RunErr(101, &Arg2); } /* * Make sure the resulting string will not be too long. */ if ((IntVal(Arg2) * StrLen(Arg1)) > MaxStrLen) RunErr(-205, NULL); /* * Return an empty string if Arg2 is 0. */ if (cnt == 0) Arg0 = emptystr; else { /* * Ensure enough space for the replicated string and allocate * a copy of s. Then allocate and copy s n - 1 times. */ if (strreq(cnt * StrLen(Arg1)) == Error) RunErr(0, NULL); sloc = alcstr(StrLoc(Arg1), StrLen(Arg1)); cnt--; while (cnt--) alcstr(StrLoc(Arg1), StrLen(Arg1)); /* * Make Arg0 a descriptor for the replicated string. */ StrLen(Arg0) = (int)IntVal(Arg2) * StrLen(Arg1); StrLoc(Arg0) = sloc; } Return; } /* * reverse(s) - reverse string s. */FncDcl(reverse,1) { register char c, *floc, *lloc; register word slen; char sbuf[MaxCvtLen]; /* * Make sure that Arg1 is a string. */ if (cvstr(&Arg1, sbuf) == CvtFail) RunErr(103, &Arg1); /* * Ensure that there is enough room and allocate a copy of Arg1. */ slen = StrLen(Arg1); if (strreq(slen) == Error) RunErr(0, NULL); StrLen(Arg0) = slen; StrLoc(Arg0) = alcstr(StrLoc(Arg1), slen); /* * Point floc at the start of Arg0 and lloc at the end of Arg0. Work floc * and lloc along Arg0 in opposite directions, swapping the characters * at floc and lloc. */ floc = StrLoc(Arg0); lloc = floc + --slen; while (floc < lloc) { c = *floc; *floc++ = *lloc; *lloc-- = c; } Return; } /* * right(s1,n,s2) - pad s1 on left with s2 to length n. */FncDcl(right,3) { register char *s, *st; word cnt, slen; char *sbuf, *s3, sbuf1[MaxCvtLen], sbuf2[MaxCvtLen]; /* * Arg1 must be a string. Arg2 must be a non-negative integer and defaults * to 1. eArg3 must be a string and defaults to a blank. */ if (cvstr(&Arg1, sbuf1) == CvtFail) RunErr(103, &Arg1); if (defshort(&Arg2, 1) == Error) RunE
++++++++ Continued on nex+++++++
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:fstr.c
+++++ Continued from previous card +++++
rr(0, NULL); if ((cnt = IntVal(Arg2)) < 0) RunErr(205, &Arg2); if (defstr(&Arg3, sbuf2, &blank) == Error) RunErr(0, NULL); if (strreq(cnt) == Error) RunErr(0, NULL); if (StrLen(Arg3) == 0) { /* * The padding string is null; make it a blank. */ slen = 1; s3 = " "; } else { slen = StrLen(Arg3); s3 = StrLoc(Arg3); } /* * Get Arg2 bytes of string space. Start at the left end of the new * string and copy Arg3 into the new string as many times as it fits. */ sbuf = alcstr(NULL, cnt); s = sbuf; while (s < sbuf + cnt) { st = s3; while (st < s3 + slen && s < sbuf + cnt) *s++ = *st++; } /* * Copy Arg1 into the new string, starting at the right end and copying * Arg3 from right to left. If *Arg1 > Arg2, only copy Arg2 bytes. */ s = sbuf + cnt; slen = StrLen(Arg1); st = StrLoc(Arg1) + slen; if (slen > cnt) slen = cnt; while (slen-- > 0) *--s = *--st; /* * Return the new string. */ StrLen(Arg0) = cnt; StrLoc(Arg0) = sbuf; Return; } /* * trim(s,c) - trim trailing characters in c from s. */FncDcl(trim,2) { char *sloc; char sbuf[MaxCvtLen]; int *cs, csbuf[CsetSize], cvted; static int spcset[CsetSize] = /* ' ' */#if !EBCDIC cset_display(0, 0, 01, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0);#else /* !EBCDIC */ cset_display(0, 0, 0, 0, 01, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0);#endif /* !EBCDIC */ /* * Arg1 must be a string. */ if ((cvted = cvstr(&Arg1, sbuf)) == CvtFail) RunErr(103, &Arg1); /* * Arg2 defaults to a cset containing a blank. */ if (defcset(&Arg2, &cs, csbuf, spcset) == Error) RunErr(0, NULL); /* * Start at the end of Arg1 and then back up until a character that is * not in Arg2 is found. The actual trimming is done by having a * descriptor * that points at a substring of Arg1, but with the length * reduced. */ Arg0 = Arg1; sloc = StrLoc(Arg1) + StrLen(Arg1) - 1; while (sloc >= StrLoc(Arg1) && Testb(*sloc, cs)) { sloc--; StrLen(Arg0)--; } /* * Save the temporary string in the string region if conversion was done. */ if (cvted == Cvt) { if (strreq(StrLen(Arg0)) == Error) RunErr(0, NULL); StrLoc(Arg0) = alcstr(StrLoc(Arg0), StrLen(Arg0)); } Return; } :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:fstranl.c
/* * File: fstranl.c * Contents: any, bal, find, many, match, upto */#include "::h:config.h"#include "::h:rt.h"#include "rproto.h"#ifdef PreProcess/* include(../M4/fncs.m4) /* *//* */#endif /* PreProcess *//* * any(c,s,i,j) - test if first character of s[i:j] is in c. */FncDcl(any,4) { register word i, j; long l1, l2; int *cs, csbuf[CsetSize]; char sbuf[MaxCvtLen]; /* * Arg1 must be a cset. Arg2 defaults to &subject; Arg3 defaults to &pos * if Arg2 defaulted, 1 otherwise. Arg4 defaults to 0. */ if (cvcset(&Arg1, &cs, csbuf) == CvtFail) RunErr(104, &Arg1); switch (defstr(&Arg2, sbuf, &k_subject)) { case Error: RunErr(0, NULL); case Defaulted: if (defint(&Arg3, &l1, k_pos) == Error) RunErr(0, NULL); break; default: if (defint(&Arg3, &l1, (word)1) == Error) RunErr(0, NULL); } if (defint(&Arg4, &l2, (word)0) == Error) RunErr(0, NULL); /* * Convert Arg3 and Arg4 to positions in Arg2. If Arg3 == Arg4 then the * specified substring of Arg2 is empty and any fails. Otherwise make * Arg3 the smaller of the two. (Arg4 is of no further use.) */ i = cvpos(l1, StrLen(Arg2)); if (i == CvtFail) Fail; j = cvpos(l2, StrLen(Arg2)); if (j == CvtFail) Fail; if (i == j) Fail; if (i > j) i = j; /* * If Arg2[Arg3] is not in the cset Arg1, fail. */ j = (word)StrLoc(Arg2)[i-1]; if (!Testb(j, cs)) Fail; /* * Return pos(s[i+1]). */ Arg0.dword = D_Integer; IntVal(Arg0) = i + 1; Return; } /* * bal(c1,c2,c3,s,i,j) - find end of a balanced substring of s[i:j]. * Generates successive positions. */FncDcl(bal,6) { register word i, j; register int cnt, c; word t; long l1, l2; int *cs1, *cs2, *cs3; int csbuf1[CsetSize], csbuf2[CsetSize], csbuf3[CsetSize]; char sbuf[MaxCvtLen]; static int lpar[CsetSize] = /* '(' */#if !EBCDIC cset_display(0, 0, 0400, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0);#else /* !EBCDIC */ cset_display(0, 0, 0, 0, 0x2000, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0);#endif /* !EBCDIC */ static int rpar[CsetSize] = /* ')' */#if !EBCDIC cset_display(0, 0, 01000, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0);#else /* !EBCDIC */ cset_display(0, 0, 0, 0, 0, 0x2000, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0);#endif /* !EBCDIC */ /* * Arg1 defaults to &cset; Arg2 defaults to '('; Arg3 defaults to * ')'; Arg4 to &subject; Arg5 to &pos if Arg4 defaulted, 1 otherwise; * Arg6 defaults to 0. */ if ((defcset(&Arg1, &cs1, csbuf1, k_cset.bits) == Error) || (defcset(&Arg2, &cs2, csbuf2, lpar) == Error) || (defcset(&Arg3, &cs3, csbuf3, rpar) == Error)) RunErr(0, NULL); switch (defstr(&Arg4, sbuf, &k_subject)) { case Error: RunErr(0, NULL); case Defaulted: if (defint(&Arg5, &l1, k_pos) == Error) RunErr(0, NULL); break; default: if (defint(&Arg5, &l1, (word)1) == Error) RunErr(0, NULL); } if (defint(&Arg6, &l2, (word)0) == Error) RunErr(0, NULL); /* * Convert Arg5 and Arg6 to positions in Arg4 and order them. */ i = cvpos(l1, StrLen(Arg4)); if (i == CvtFail) Fail; j = cvpos(l2, StrLen(Arg4)); if (j == CvtFail) Fail; if (i > j) { t = i; i = j; j = t; } /* * Loop through characters in Arg4[Arg5:Arg6]. When a character in Arg2 is * found, increment cnt; when a character in Arg3 is found, decrement * cnt. When cnt is 0 there have been an equal number of occurrences * of characters in Arg2 and Arg3, i.e., the string to the left of * i is balanced. If the string is balanced and the current character * (Arg4[i]) is in Arg1, suspend with i. Note that if cnt drops below * zero, bal fails. */ cnt = 0; Arg0.dword = D_Integer; while (i < j) { c = StrLoc(Arg4)[i-1]; if (cnt == 0 && Testb(c, cs1)) { IntVal(Arg0) = i; Suspend; } if (Testb(c, cs2)) cnt++; else if (Testb(c, cs3)) cnt--; if (cnt < 0) Fail; i++; } /* * Eventually fail. */ Fail; } /* * find(s1,s2,i,j) - find string s1 in s2[i:j] and return position in * s2 of beginning of s1. * Generates successive positions. */FncDcl(find,4) { register word l; register char *s1, *s2; word i, j, t; long l1, l2; char sbuf1[MaxCvtLen], sbuf2[MaxCvtLen]; /* * Arg1 must be a string. Arg2 defaults to &subject; Arg3 defaults * to &pos if Arg2 is defaulted, or to 1 otherwise; Arg4 defaults * to 0. */ if (cvstr(&Arg1, sbuf1) == CvtFail) RunErr(103, &Arg1); switch (defstr(&Arg2, sbuf2, &k_subject)) { case Error: RunErr(0, NULL); case Defaulted: if (defint(&Arg3, &l1, k_pos) == Error) RunErr(0, NULL); break; default: if (defint(&Arg3, &l1, (word)1) == Error) RunErr(0, NULL); } if (defint(&Arg4, &l2, (word)0)== Error) RunErr(0, NULL); /* * Convert Arg3 and Arg4 to absolute positions in Arg2 and order them. */ i = cvpos(l1, StrLen(Arg2)); if (i == CvtFail) Fail; j = cvpos(l2, StrLen(Arg2)); if (j == CvtFail) Fail; if (i > j) { t = i; i = j; j = t; } /* * Loop through Arg2[i:j] trying to find Arg1 at each point, stopping * when the remaining portion Arg2[i:j] is too short to contain Arg1. */ Arg0.dword = D_Integer; while (i <= j - StrLen(Arg1)) { s1 = StrLoc(Arg1); s2 = StrLoc(Arg2) + i - 1; l = StrLen(Arg1); /* * Compare strings on a byte-wise basis; if the end is reached * before inequality is found, suspend with the position of the * string. */ do { if (l-- <= 0) { IntVal(Arg0) = i; Suspend; break; } } while (*s1++ == *s2++); i++; } Fail; } /* * many(c,s,i,j) - find longest prefix of s[i:j] of characters in c. */FncDcl(many,4) { register word i, j, t; int *cs, csbuf[CsetSize]; long l1, l2; char sbuf[MaxCvtLen]; /* * Arg1 must be a cset. Arg2 defaults to &subject; Arg3 defaults to * &pos if Arg2 defaulted, 1 otherwise; Arg4 defaults to 0. */ if (cvcset(&Arg1, &cs, csbuf) == CvtFail) RunErr(104, &Arg1); switch (defstr(&Arg2, sbuf, &k_subject)) { case Error: RunErr(0, NULL); case Defaulted: if (defint(&Arg3, &l1, k_pos) == Error) RunErr(0, NULL); break; default: if (defint(&Arg3, &l1, (word)1) == Error) RunErr(0, NULL); } if (defint(&Arg4, &l2, (word)0) == Error) RunErr(0, NULL); /* * Convert Arg3 and Arg4 to absolute positions and order them. */ i = cvpos(l1, StrLen(Arg2)); if (i == CvtFail) Fail; j = cvpos(l2, StrLen(Arg2)); if (j == CvtFail) Fail; if (i == j) Fail; if (i > j) { t = i; i = j; j = t; } /* * Fail if first character of Arg2[i:j] is not in Arg1. */ t = (word)StrLoc(Arg2)[i-1]; if (!Testb(t, cs)) Fail; /* * Move i along Arg2[i:j] until a character that is not in Arg1 is found or * the end of the string is reached. */ i++; while (i < j) { t = (word)StrLoc(Arg2)[i-1]; if (!Testb(t, cs)) break; i++; } /* * Return the position of the first character not in Arg1. */ Arg0.dword = D_Integer; IntVal(Arg0) = i; Return; } /* * match(s1,s2,i,j) - test if s1 is prefix of s2[i:j]. */FncDcl(match,4) { register word i; register char *s1, *s2; word j, t; long l1, l2; char sbuf1[MaxCvtLen], sbuf2[MaxCvtLen]; /* * Arg1 must be a string. Arg2 defaults to &subject; Arg3 defaults * to &pos if Arg2 defaulted, 1 otherwise; Arg4 defaults to 0. */ if (cvstr(&Arg1, sbuf1) == CvtFail) RunErr(103, &Arg1); switch (defstr(&Arg2, sbuf2, &k_subject)) { case Error: RunErr(0, NULL); case Defaulted: if (defint(&Arg3, &l1, k_pos) == Error) RunErr(0, NULL); break; default: if (defint(&Arg3, &l1, (word)1) == Error) RunErr(0, NULL); } if (defint(&Arg4, &l2, (word)0) == Error) RunErr(0, NULL); /* * Convert Arg3 and Arg4 to absolute positions and order them. */ i = cvpos(l1, StrLen(Arg2)); if (i == CvtFail) Fail; j = cvpos(l2, StrLen(Arg2)); if (j == CvtFail) Fail; if (i > j) { t = i; i = j; j = t - j; } else j = j - i; /* * Cannot match unless Arg1 is as long as Arg2[i:j]. */ if (j < StrLen(Arg1)) Fail; /* * Compare Arg1 with Arg2[i:j] for *Arg1 characters; fail if an inequality * if found. */ s1 = StrLoc(Arg1); s2 = StrLoc(Arg2) + i - 1; for (j = StrLen(Arg1); j > 0; j--) if (*s1++ != *s2++) Fail; /* * Return position of end of matched string in Arg2. */ Arg0.dword = D_Integer; IntVal(Arg0) = i + StrLen(Arg1); Return; } /* * upto(c,s,i,j) - find each occurrence in s[i:j] of a character in c. * Generates successive positions. */FncDcl(upto,4) { register word i, j, t; long l1, l2; int *cs, csbuf[CsetSize]; char sbuf[MaxCvtLen]; /* * Arg1 must be a cset. Arg2 defaults to &subject; Arg3 defaults * to &pos if Arg2 defaulted, 1 otherwise; Arg4 defaults to 0. */ if (cvcset(&Arg1, &cs, csbuf) == CvtFail) RunErr(104, &Arg1); switch (defstr(&Arg2, sbuf, &k_subject)) { case Error: RunErr(0, NULL); case Defaulted: if (defint(&Arg3, &l1, k_pos) == Error) RunErr(0, NULL); break; default: if (defint(&Arg3, &l1, (word)1) == Error) RunErr(0, NULL); } if (defint(&Arg4, &l2, (word)0) == Error) RunErr(0, NULL); /* * Convert Arg3 and Arg4 to positions in Arg2 and order them. */ i = cvpos(l1, StrLen(Arg2)); if (i == CvtFail) Fail; j = cvpos(l2, StrLen(Arg2)); if (j == CvtFail) Fail; if (i > j) { t = i; i = j; j = t; } /* * Look through Arg2[i:j] and suspend position of each occurrence of * of a character in Arg1. */ while (i < j) { t = (word)StrLoc(Arg2)[i-1]; if (Testb(t, cs)) { Arg0.dword = D_Integer; IntVal(Arg0) = i; Suspend; } i++; } /* * Eventually fail. */ Fail; } :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:fstruct.c
/* * File: fstruct.c * Contents: delete, get, key, insert, list, member, pop, pull, push, put, set, * table */#include "::h:config.h"#include "::h:rt.h"#include "rproto.h"#ifdef PreProcess/* include(../M4/fncs.m4) /* *//* */#endif /* PreProcess *//* * delete(X,x) - delete element x from set or table X if it is there * (always succeeds and returns X). */FncDcl(delete,2) { register union block **pd; register uword hn; int res; if (Qual(Arg1)) RunErr(122, &Arg1); /* * The technique and philosophy here are the same * as used in insert - see comment there. */ switch (Type(Arg1)) { case T_Set: case T_Table: hn = hash(&Arg2); pd = memb(BlkLoc(Arg1), &Arg2, hn, &res); if (res == 1) { /* * The element is there so delete it. */ *pd = (*pd)->selem.clink; (BlkLoc(Arg1)->set.size)--; } break; default: RunErr(122, &Arg1); } Arg0 = Arg1; Return; } /* * get(x) - get an element from end of list x. * Identical to pop(x). */FncDcl(get,1) { register word i; register struct b_list *hp; register struct b_lelem *bp; /* * Arg1 must be a list. */ if (Arg1.dword != D_List) RunErr(108, &Arg1); /* * Fail if the list is empty. */ hp = (struct b_list *) BlkLoc(Arg1); if (hp->size <= 0) Fail; /* * Point bp at the first list block. If the first block has no * elements in use, point bp at the next list block. */ bp = (struct b_lelem *) hp->listhead; if (bp->nused <= 0) { bp = (struct b_lelem *) bp->listnext; hp->listhead = (union block *) bp; bp->listprev = NULL; } /* * Locate first element and assign it to Arg0 for return. */ i = bp->first; Arg0 = bp->lslots[i]; /* * Set bp->first to new first element, or 0 if the block is now * empty. Decrement the usage count for the block and the size * of the list. */ if (++i >= bp->nslots) i = 0; bp->first = i; bp->nused--; hp->size--; Return; } /* * key(t) - generate successive keys (entry values) from table t. */FncDcl(key,2) { if (Arg1.dword != D_Table) RunErr(124, &Arg1); MakeInt(1, &Arg2); /* indicate that we want the keys */ Forward(hgener); /* go to the hash generator */ } /* * insert(X,x) - insert element x into set or table X if not already there * (always succeeds and returns X). */FncDcl(insert,3) { register union block *bp; register union block **pd; register struct b_telem *pe; register uword hn; int res; if (Qual(Arg1)) RunErr(122, &Arg1); switch (Type(Arg1)) { case T_Set: /* * We may need at most one new element. */ if (blkreq((word)sizeof(struct b_selem)) == Error) RunErr(0, NULL); bp = BlkLoc(Arg1); hn = hash(&Arg2); /* * If Arg2 is a member of set Arg1 then res will have the * value 1 and pd will have a pointer to the pointer * that points to that member. * If Arg2 is not a member of the set then res will have * the value 0 and pd will point to the pointer * which should point to the member - thus we know where * to link in the new element without having to do any * repetitive looking. */ pd = memb(bp, &Arg2, hn, &res); if (res == 0) { /* * The element is not in the set - insert it. */ addmem((struct b_set *)bp, alcselem(&Arg2, hn), pd); if (TooCrowded(bp)) hgrow(&Arg1); } break; case T_Table: if (blkreq((word)sizeof(struct b_telem)) == Error) RunErr(0, NULL); bp = BlkLoc(Arg1); hn = hash(&Arg2); pd = memb(bp, &Arg2, hn, &res); if (res == 0) { /* * The element is not in the table - insert it. */ bp->table.size++; pe = alctelem(); pe->clink = *pd; *pd = (union block *)pe; pe->hashnum = hn; pe->tref = Arg2; pe->tval = Arg3; if (TooCrowded(bp)) hgrow(&Arg1); } else { pe = (struct b_telem *) *pd; pe->tval = Arg3; } break; default: RunErr(122, &Arg1); } Arg0 = Arg1; Return; } /* * list(n,x) - create a list of size n, with initial value x. */FncDcl(list,2) { register word i, size; word nslots; register struct b_list *hp; register struct b_lelem *bp; if (defshort(&Arg1, 0) == Error) RunErr(0, NULL); nslots = size = IntVal(Arg1); /* * Ensure that the size is positive and that the list-element block * has MinListSlots slots if its size is zero. */ if (size < 0) RunErr(205, &Arg1); if (nslots == 0) nslots = MinListSlots; /* * Ensure space for a list-header block, and a list-element block * with nslots slots. */ if (blkreq(sizeof(struct b_list) + sizeof(struct b_lelem) + (nslots - 1) * sizeof(struct descrip)) == Error) RunErr(0, NULL); /* * Allocate the list-header block and a list-element block. * Note that nslots is the number of slots in the list-element * block while size is the number of elements in the list. */ hp = alclist(size); bp = alclstb(nslots, (word)0, size); hp->listhead = hp->listtail = (union block *) bp; /* * Initialize each slot. */ for (i = 0; i < size; i++) bp->lslots[i] = Arg2; /* * Return the new list. */ Arg0.dword = D_List; BlkLoc(Arg0) = (union block *) hp; Return; } /* * member(X,x) - returns x if x is a member of set or table X otherwise fails. */FncDcl(member,2) { int res; register uword hn; if (Qual(Arg1)) RunErr(122, &Arg1); switch (Type(Arg1)) { case T_Set: case T_Table: hn = hash(&Arg2); memb(BlkLoc(Arg1), &Arg2, hn, &res); break; default: RunErr(122, &Arg1); } /* If Arg2 is a member of Arg1 then "res" will have the * value 1 otherwise it will have the value 0. */ if (res == 1) { /* It is a member. */ Arg0 = Arg2; /* Return the member if it is in Arg1. */ Return; } Fail; } /* * pop(x) - pop an element from beginning of list x. */FncDcl(pop,1) { register word i; register struct b_list *hp; register struct b_lelem *bp; /* * Arg1 must be a list. */ if (Arg1.dword != D_List) RunErr(108, &Arg1); /* * Fail if the list is empty. */ hp = (struct b_list *) BlkLoc(Arg1); if (hp->size <= 0) Fail; /* * Point bp to the first list-element block. If the first block has * no slots in use, point bp at the next list-element block. */ bp = (struct b_lelem *) hp->listhead; if (bp->nused <= 0) { bp = (struct b_lelem *) bp->listnext; hp->listhead = (union block *) bp; bp->listprev = NULL; } /* * Locate first element and assign it to Arg0 for return. */ i = bp->first; Arg0 = bp->lslots[i]; /* * Set bp->first to new first element, or 0 if the block is now * empty. Decrement the usage count for the block and the size * of the list. */ if (++i >= bp->nslots) i = 0; bp->first = i; bp->nused--; hp->size--; Return; } /* * pull(x) - pull an element from end of list x. */FncDcl(pull,1) { register word i; register struct b_list *hp; register struct b_lelem *bp; /* * Arg1 must be a list. */ if (Arg1.dword != D_List) RunErr(108, &Arg1); /* * Point at list header block and fail if the list is empty. */ hp = (struct b_list *) BlkLoc(Arg1); if (hp->size <= 0) Fail; /* * Point bp at the last list element block. If the last block has no * elements in use, point bp at the previous list element block. */ bp = (struct b_lelem *) hp->listtail; if (bp->nused <= 0) { bp = (struct b_lelem *) bp->listprev; hp->listtail = (union block *) bp; bp->listnext = NULL; } /* * Set i to position of last element and assign the element to * Arg0 for return. Decrement the usage count for the block * and the size of the list. */ i = bp->first + bp->nused - 1; if (i >= bp->nslots) i -= bp->nslots; Arg0 = bp->lslots[i]; bp->nused--; hp->size--; Return; } /* * push(x,val) - push val onto beginning of list x. */FncDcl(push,2) { register word i; register struct b_list *hp; register struct b_lelem *bp; static two = 2; /* some compilers generat bad code for division by a constant that's a power of 2 */ /* * Arg1 must be a list. */ if (Arg1.dword != D_List) RunErr(108, &Arg1); /* * Point hp at the list-header block and bp at the first * list-element block. */ hp = (struct b_list *) BlkLoc(Arg1); bp = (struct b_lelem *) hp->listhead; /* * If the first list-element block is full, allocate a new * list-element block, make it the first list-element block, * and make it the previous block of the former first list-element * block. */ if (bp->nused >= bp->nslots) { /* * Set i to the size of block to allocate. */ i = hp->size / two; if (i < MinListSlots) i = MinListSlots; /* * Ensure space for a new list element block. If the block can't * be allocated, try smaller blocks. */ while (blkreq((word)sizeof(struct b_lelem) + i * sizeof(struct descrip)) == Error) { i /= 4; if (i < MinListSlots) RunErr(0, NULL); } /* * Reset hp in case there was a garbage collection. */ hp = (struct b_list *) BlkLoc(Arg1); bp = alclstb(i, (word)0, (word)0); hp->listhead->lelem.listprev = (union block *) bp; bp->listnext = hp->listhead; hp->listhead = (union block *) bp; } /* * Set i to position of new first element and assign val (Arg2) to * that element. */ i = bp->first - 1; if (i < 0) i = bp->nslots - 1; bp->lslots[i] = Arg2; /* * Adjust value of location of first element, block usage count, * and current list size. */ bp->first = i; bp->nused++; hp->size++; /* * Return the list. */ Arg0 = Arg1; Return; } /* * put(x,val) - put val onto end of list x. */FncDcl(put,2) { register word i; register struct b_list *hp; register struct b_lelem *bp; static two = 2; /* some compilers generate bad code for division by a constant that's a power of 2 */ /* * Arg1 must be a list. */ if (Arg1.dword != D_List) RunErr(108, &Arg1); /* * Point hp at the list-header block and bp at the last * list-element block. */ hp = (struct b_list *) BlkLoc(Arg1); bp = (struct b_lelem *) hp->listtail; /* * If the last list-element block is full, allocate a new * list-element block, make it the first list-element block, * and make it the next block of the former last list-element * block. */ if (bp->nused >= bp->nslots) { /* * Set i to the size of block to allocate. */ i = hp->size / two; if (i < MinListSlots) i = MinListSlots; /* * Ensure space for a new list element block. If the block can't * be allocated, try smaller blocks. */ while (blkreq((word)sizeof(struct b_lelem) + i * sizeof(struct descrip)) == Error) { i /= 4; if (i < MinListSlots) RunErr(0, NULL); /* * Reset hp in case there was a garbage collection. */ hp = (struct b_list *) BlkLoc(Arg1); bp = alclstb(i, (word)0, (word)0); hp->listtail->lelem.listnext = (union block *) bp; bp->listprev = hp->listtail; hp->listtail = (union block *) bp; } /* * Set i to position of new last element and assign Arg2 to * that element. */ i = bp->first + bp->nused; if (i >= bp->nslots) i -= bp->nslots; bp->lslots[i] = Arg2; /* * Adjust block usage count and current list size. */ bp->nused++; hp->size++; /* * Return the list. */ Arg0 = Arg1; Return; } /* * set(list) - create a set with members in list. * The members are linked into hash chains which are * arranged in increasing order by hash number. */FncDcl(set,1) { register uword hn; register dptr pd; register union block *ps, *pb; struct b_selem *ne; union block **pe; int res; word i, j; if (ChkNull(Arg1)) { /* Create empty set */ ps = hmake(T_Set, (word)0, (word)0); if (ps == NULL) RunErr(0,NULL); Arg0.dword = D_Set; BlkLoc(Arg0) = ps; Return; } if (Arg1.dword != D_List) RunErr(108, &Arg1); /* * Make a set of the appropriate size. */ ps = hmake(T_Set, (word)0, BlkLoc(Arg1)->list.size); if (ps == NULL) RunErr(0, NULL); /* * Chain through each list block and for * each element contained in the block * insert the element into the set if not there. */ for (pb = BlkLoc(Arg1)->list.listhead; pb != NULL; pb = pb->lelem.listnext) { for (i = 0; i < pb->lelem.nused; i++) { j = pb->lelem.first + i; if (j >= pb->lelem.nslots) j -= pb->lelem.nslots; pd = &pb->lelem.lslots[j]; pe = memb(ps, pd, hn = hash(pd), &res); if (res == 0) { ne = alcselem(pd,hn); addmem((struct b_set *)ps, ne, pe); } } } Arg0.dword = D_Set; BlkLoc(Arg0) = ps; Return; } /* * table(x) - create a table with default value x. */FncDcl(table,1) { union block *bp; bp = hmake(T_Table, (word)0, (word)0); if (bp == NULL) RunErr(0, NULL); bp->table.defvalue = Arg1; Arg0.dword = D_Table; BlkLoc(Arg0) = bp; Return; } :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:fsys.c
/* * File: fsys.c * Contents: close, exit, getenv, open, read, reads, remove, rename, [save], * seek, stop, [system], where, write, writes, [getch, getche, kbhit] */#include "::h:config.h"#include "::h:rt.h"#include "rproto.h"#ifdef PreProcess/* include(../M4/fncs.m4) /* *//* */#endif /* PreProcess */#if MICROSOFT || SCO_XENIX#define BadCode#endif /* MICROSOFT || SCO_XENIX */#ifdef XENIX_386#define register#endif /* XENIX_386 */#if MACINTOSH#if MPW#include <FCntl.h>#include <IOCtl.h>#include <Files.h>#define isatty(fd) (!ioctl((fd), FIOINTERACTIVE))/* * myfflush() -- Permits environment variable option as to whether * console output should be automatically flushed after each line of * output. */intmyfflush(f)FILE *f; { static short initialized = 0; static short nolineflush; if (!initialized) { initialized = 1; nolineflush = getenv("NOLINEFLUSH") != NULL; } return nolineflush ? 0 : fflush(f); }#define fflush(lush(f))#endif /* MPW */#endif /* MACINTOSH */ /* * close(f) - close file f. */FncDcl(close,1) { FILE *f; /* * Arg1 must be a file. */ if (Arg1.dword != D_File) RunErr(105, &Arg1); /* * Close Arg1, using fclose or pclose as appropriate. */#if UNIX || VMS if (BlkLoc(Arg1)->file.status & Fs_Pipe) { BlkLoc(Arg1)->file.status = 0; MakeInt((long)((pclose(BlkLoc(Arg1)->file.fd) >> 8) & 0377), &Arg0); Return; } else#endif /* UNIX || VMS */ f = BlkLoc(Arg1)->file.fd; fclose(f); BlkLoc(Arg1)->file.status = 0; /* * Return the closed file. */ Arg0 = Arg1; Return; } /* * exit(status) - exit process with specified status, defaults to 0. */FncDcl(exit,1) { if (defshort(&Arg1, NormalExit) == Error) RunErr(0, NULL); c_exit((int)IntVal(Arg1)); } /* * getenv(s) - return contents of environment variable s */FncDcl(getenv,1) {#ifndef EnvVars RunErr(-121, NULL);#else /* EnvVars */ register char *p; register word len; char sbuf[256]; /* * Make a C-style string out of Arg1 */ switch (cvstr(&Arg1, sbuf)) { case Cvt: /* Already converted to a C-style string */ break; case NoCvt: qtos(&Arg1, sbuf); break; default: RunErr(103, &Arg1); } if ((p = getenv(StrLoc(Arg1))) != NULL) { /* get environment variable */ len = strlen(p); if (strreq(len) == Error) RunErr(0, NULL); StrLen(Arg0) = len; StrLoc(Arg0) = alcstr(p, len); Return; } else /* fail if not in environment */ Fail;#endif /* EnvVars */ } /* * open(s1,s2) - open file s1 with specification s2. */FncDcl(open,2) { register word slen; register int i; register char *s; int status; char mode[4]; extern FILE *fopen(); char sbuf1[MaxCvtLen], sbuf2[MaxCvtLen]; char *openstring; FILE *f;/* * The following code is operating-system dependent [@fsys.01]. Make * declarations as needed for opening files. */#if PORTDeliberate Syntax Error#endif /* PORT */#if AMIGA || MVS || VM /* nothing is needed */#endif /* AMIGA || MACINTOSH */#if ATARI_ST || HIGHC_386 || MSDOS || OS2 char untranslated;#endif /* ATARI_ST || HIGHC_386 || ... */#if MACINTOSH#if LSC char untranslated;#endif /* LSC */#endif /* MACINTOSH */#if UNIX || VMS extern FILE *popen();#endif /* UNIX || VMS *//* * End of operating-system specific code. */ /* * Arg1 must be a string and a C string copy of it is also needed. * Make it a string if it is not one; make a C string if Arg1 is * a string. */ switch (cvstr(&Arg1, sbuf1)) { case Cvt: openstring = StrLoc(Arg1); if (strreq(StrLen(Arg1)) == Error) RunErr(0, NULL); StrLoc(Arg1) = alcstr(StrLoc(Arg1), StrLen(Arg1)); break; case NoCvt: tended[1] = Arg1; ntended = 1; qtos(&tended[1], sbuf1); openstring = StrLoc(tended[1]); break; default: RunErr(103, &Arg1); } /* * s2 defaults to "r". */ if (defstr(&Arg2, sbuf2, &letr) == Error) RunErr(0, NULL); if (blkreq((word)sizeof(struct b_file)) == Error) RunErr(0, NULL); status = 0;/* * The following code is operating-system dependent [@fsys.02]. Provide * declaration for untranslated line-termination mode, if supported. */#if PORT /* nothing to do */Deliberate Syntax Error#endif /* PORT */#if AMIGA /* translated mode could be supported, but is not now */#endif /* AMIGA */#if ATARI_ST || HIGHC_386 || MSDOS || OS2 untranslated = 0;#endif /* ATARI_ST || HIGHC_386 || ... */#if MACINTOSH#if LSC untranslated = 0;#endif /* LSC */#endif /* MACINTOSH */#if MVS || UNIX || VM || VMS /* nothing to do */#endif /* UNIX || VMS *//* * End of operating-system specific code. */ /* * Scan Arg2, setting appropriate bits in status. Produce a run-time error * if an unknown character is encountered. */ s = StrLoc(Arg2); slen = StrLen(Arg2); for (i = 0; i < slen; i++) { switch (*s++) { case 'a': case 'A': status |= Fs_Write|Fs_Append; continue; case 'b': case 'B': status |= Fs_Read|Fs_Write; continue; case 'c': case 'C': status |= Fs_Create|Fs_Write; continue; case 'r': case 'R': status |= Fs_Read; continue; case 'w': case 'W': status |= Fs_Write; continue;/* * The following code is operating-system dependent [@fsys.03]. Handle * untranslated line-terminator mode and pipes, if supported. */#if PORT case 't': case 'T': case 'u': case 'U': continue; /* no-op */Deliberate Syntax Error#endif /* PORT */#if AMIGA || MVS || VM case 't': case 'T': case 'u': case 'U': continue; /* no-op */#endif /* AMIGA || MVS || VM */#if ATARI_ST || HIGHC_386 || MSDOS || OS2 case 't': case 'T': untranslated = 0; continue; case 'u': case 'U': untranslated = 1; continue;#endif /* ATARI_ST || HIGHC_386 || ... */#if MACINTOSH#if LSC case 't': case 'T': untranslated = 0; continue; case 'u': case 'U': untranslated = 1; continue;#endif /* LSC */#endif /* MACINTOSH */#if UNIX || VMS case 't': case 'T': case 'u': case 'U': continue; /* no-op */ case 'p': case 'P': status |= Fs_Pipe; continue;#endif /* UNIX || VMS *//* * End of operating-system specific code. */ default: RunErr(209, &Arg2); } } /* * Construct a mode field for fopen/popen. */ mode[0] = '\0'; mode[1] = '\0'; mode[2] = '\0'; mode[3] = '\0'; if ((status & (Fs_Read|Fs_Write)) == 0) /* default: read only */ status |= Fs_Read; if (status & Fs_Create) mode[0] = 'w'; else if (status & Fs_Append) mode[0] = 'a'; else if (status & Fs_Read) mode[0] = 'r'; else mode[0] = 'w';/* * The following code is operating-system dependent [@fsys.04]. Handle open * modes. */#if PORT if ((status & (Fs_Read|Fs_Write)) == (Fs_Read|Fs_Write)) mode[1] = '+';Deliberate Syntax Error#endif /* PORT */#if ATARI_ST if ((status & (Fs_Read|Fs_Write)) == (Fs_Read|Fs_Write)) { mode[1] = '+'; mode[2] = untranslated ? 'b' : 'a'; } else mode[1] = untranslated ? 'b' : 'a';#endif /* ATARI_ST */#if HIGHC_386 || OS2 if ((status & (Fs_Read|Fs_Write)) == (Fs_Read|Fs_Write)) { mode[1] = '+'; mode[2] = untranslated ? 'b' : 't'; } else mode[1] = untranslated ? 'b' : 't';#endif /* HIGHC_386 || OS2 */#if MACINTOSH#if LSC if ((status & (Fs_Read|Fs_Write)) == (Fs_Read|Fs_Write)) { mode[1] = '+'; if (untranslated) mode[2] = 'b'; } else if (untranslated) mode[1] = 'b';#endif /* LSC */#endif /* MACINTOSH */#if MSDOS#if MICROSOFT || TURBO if ((status & (Fs_Read|Fs_Write)) == (Fs_Read|Fs_Write)) { mode[1] = '+'; mode[2] = untranslated ? 'b' : 't'; } else mode[1] = untranslated ? 'b' : 't';#endif /* MICROSOFT || TURBO */#if LATTICE || MWC if ((status & (Fs_Read|Fs_Write)) == (Fs_Read|Fs_Write)) { mode[1] = '+'; if (untranslated) mode[2] = 'b'; } else if (untranslated) mode[1] = 'b';#endif /* LATTICE || MWC */#endif /* HIGHC_386 || MSDOS */#if AMIGA || MACINTOSH || MVS || UNIX || VM || VMS if ((status & (Fs_Read|Fs_Write)) == (Fs_Read|Fs_Write)) mode[1] = '+';#endif /* AMIGA || MACINTOSH || UNIX || VMS *//* * End of operating-system specific code. */ /* * Open the file with fopen or popen. */#if UNIX || VMS if (status & Fs_Pipe) { if (status != (Fs_Read|Fs_Pipe) && status != (Fs_Write|Fs_Pipe)) RunErr(209, &Arg2); f = popen(openstring, mode); } else#endif /* UNIX || VMS */ f = fopen(openstring, mode); /* * Fail if the file cannot be opened. */ if (f == NULL) Fail;#if MACINTOSH#if MPW/* Set file type and creator. */ { FInfo info; if (getfinfo(openstring,0,&info) == 0) { if (status & Fs_Write && info.fdType == 0 && info.fdCreator == 0) { info.fdType = 'TEXT'; info.fdCreator = 'MPS '; setfinfo(openstring,0,&info); } } }#endif /* MPW */#endif /* MACINTOSH */ /* * Return the resulting file value. */ Arg0.dword = D_File; BlkLoc(Arg0) = (union block *) alcfile(f, status, &Arg1); ntended = 0; Return; } /* * read(f) - read line on file f. */FncDcl(read,1) { register word slen, rlen; register char *sp; int status; static char sbuf[MaxReadStr]; FILE *f; /* * Default Arg1 to &input. */ if (deffile(&Arg1, &input) == Error) RunErr(0, NULL); /* * Get a pointer to the file and be sure that it is open for reading. */ f = BlkLoc(Arg1)->file.fd; status = (int)BlkLoc(Arg1)->file.status; if ((status & Fs_Read) == 0) RunErr(212, &Arg1); /* * Use getstrg to read a line from the file, failing if getstrg * encounters end of file. [[ What about -2?]] */ StrLen(Arg0) = 0; do { if ((slen = getstrg(sbuf,MaxReadStr,f)) == -1) Fail; /* * Allocate the string read and make Arg0 a descriptor for it. */ rlen = slen < 0 ? (word)MaxReadStr : slen; if (strreq(rlen) == Error) RunErr(0, NULL); sp = alcstr(sbuf,rlen); if (StrLen(Arg0) == 0) StrLoc(Arg0) = sp; StrLen(Arg0) += rlen; } while (slen < 0); Return; } /* * reads(f,i) - read i characters on file f. */FncDcl(reads,2) { register word cnt; long tally; int status; FILE *f; /* * Arg1 defaults to &input and Arg2 defaults to 1 (character). */ if ((deffile(&Arg1, &input) == Error) || (defshort(&Arg2, 1) == Error)) RunErr(0, NULL); /* * Get a pointer to the file and be sure that it is open for reading. */ f = BlkLoc(Arg1)->file.fd; status = (int)BlkLoc(Arg1)->file.status; if ((status & Fs_Read) == 0) RunErr(212, &Arg1); /* * Be sure that a positive number of bytes is to be read. */ if ((cnt = IntVal(Arg2)) <= 0) RunErr(205, &Arg2); /* * Ensure that enough space for the string exists and read it directly * into the string space. (By reading directly into the string space, * no arbitrary restrictions are placed on the size of the string that * can be read.) Make Arg0 a descriptor for the string and return it. */ if (strreq(cnt) == Error) RunErr(0, NULL); if (strfree + cnt > strend) syserr("reads allocation botch"); StrLoc(Arg0) = strfree;#if AMIGA /* * The following code is special for Lattice 4.0 -- it was different * for Lattice 3.10. It probably won't work correctly with other * C compilers. */ if (IsInteractive(_ufbs[fileno(f)].ufbfh)) { if ((cnt = read(fileno(f),StrLoc(Arg0),cnt)) <= 0) Fail; StrLen(Arg0) = cnt; alcstr(NULL, cnt); Return; }#endif /* AMIGA */ tally = longread(StrLoc(Arg0),sizeof(char),cnt,f); if (tally == 0) Fail; StrLen(Arg0) = tally; alcstr(NULL, (word)tally); Return; } /* * remove(s) - remove the file named s. */FncDcl(remove,1) { char sbuf[MaxCvtLen]; /* * Make a C-style string out of Arg1 */ switch (cvstr(&Arg1, sbuf)) { case Cvt: /* Already converted to a C-style string */ break; case NoCvt: qtos(&Arg1, sbuf); break; default: RunErr(103, &Arg1); } if (unlink(StrLoc(Arg1)) != 0) Fail; Arg0 = nulldesc; Return; } /* * rename(s1,s2) - rename the file named s1 to have the name s2. */FncDcl(rename,2) { char sbuf1[MaxCvtLen], sbuf2[MaxCvtLen]; /* * Make a C-style string out of Arg1 */ switch (cvstr(&Arg1, sbuf1)) { case Cvt: /* Already converted to a C-style string */ break; case NoCvt: qtos(&Arg1, sbuf1); break; default: RunErr(103, &Arg1); } /* * Make a C-style string out of Arg2 */ switch (cvstr(&Arg2, sbuf2)) { case Cvt: /* Already converted to a C-style string */ break; case NoCvt: qtos(&Arg2, sbuf2); break; default: RunErr(103, &Arg2); }/* * The following code is operating-system dependent [@fsys.05]. Rename the * file, and fail if unsuccessful. */#if PORT /* need something */Deliberate Syntax Error#endif /* PORT */#if AMIGA || ATARI_ST || HIGHC_386 || MACINTOSH || MSDOS || MVS || OS2 || VM || VMS { if (rename(StrLoc(Arg1),StrLoc(Arg2)) != 0) Fail; }#endif /* AMIGA || ATARI_ST ... */#if UNIX if (link(StrLoc(Arg1),StrLoc(Arg2)) != 0) Fail; if (unlink(StrLoc(Arg1)) != 0) { unlink(StrLoc(Arg2)); /* try to undo partial rename */ Fail; }#endif /* UNIX *//* * End of operating-system specific code. */ Arg0 = nulldesc; Return; } #ifdef ExecImages/* * save(s) - save the run-time system in file s */FncDcl(save,1) { char sbuf[MaxCvtLen]; int f, fsz; dumped = 1; /* if (ChkNull(Arg1)) { abort(); } */ /* * Make a C-style string out of Arg1. */ switch (cvstr(&Arg1, sbuf)) { case Cvt: /* Already converted to a C-style string */ break; case NoCvt: qtos(&Arg1, sbuf); break; default: RunErr(103, &Arg1); } /* * Open the file for the executable image. */ f = creat(StrLoc(Arg1), 0777); if (f == -1) Fail; fsz = wrtexec(f); /* * It happens that most wrtexecs don't check the system call return * codes and thus they'll never return -1. Nonetheless... */ if (fsz == -1) Fail; /* * Return the size of the data space. */ MakeInt(fsz, &Arg0); Return; }#endif /* ExecImages */ /* * seek(file,position) - seek to byte byte position in file. * [[ What about seek error ? ]] */FncDcl(seek,2) { long l1; FILE *fd; if
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:fsys.c
+++++ Continued from previous card +++++
(Arg1.dword != D_File) RunErr(-105, NULL); if (defint(&Arg2, &l1, 1L) == Error) RunErr(0, NULL); fd = BlkLoc(Arg1)->file.fd; if (BlkLoc(Arg1)->file.status == 0) Fail; if (l1 > 0) { if (fseek(fd, l1 - 1, 0) == -1) Fail; } else { if (fseek(fd, l1, 2) == -1) Fail; } Arg0 = Arg1; Return; } /* * stop(a,b,...) - write arguments (starting on error output) and stop. */FncDclV(stop) { register word n; char sbuf[MaxCvtLen]; FILE *f;#ifdef BadCode struct descrip temp;#endif /* BadCode */ f = stderr; ntended = 0; /* * Loop through arguments. */ for (n = 1; n <= nargs; n++) {#ifdef BadCode temp = Arg(n); /* workaround for Microsoft C bug */ tended[1] = temp;#else /* BadCode */ tended[1] = Arg(n);#endif /* BadCode */ if (tended[1].dword == D_File) { if (n > 1) putc('\n', f); if ((BlkLoc(tended[1])->file.status & Fs_Write) == 0) RunErr(213, &tended[1]); f = BlkLoc(tended[1])->file.fd; } else { if (n == 1 && (k_output.status & Fs_Write) == 0) RunErr(-213, NULL); if (ChkNull(tended[1])) tended[1] = emptystr; if (cvstr(&tended[1], sbuf) == CvtFail) RunErr(109, &tended[1]); putstr(f, &tended[1]); } } putc('\n', f); fflush(f); c_exit(ErrorExit); } #ifdef SystemFnc/* * system(s) - execute string s as a system command. */FncDcl(system,1) { char sbuf[MaxCvtLen]; char *systemstring; /* * Make a C-style string out of Arg1 */ switch (cvstr(&Arg1, sbuf)) { case Cvt: /* Already converted to a C-style string */ break; case NoCvt: qtos(&Arg1, sbuf); break; default: RunErr(103, &Arg1); } systemstring = StrLoc(Arg1); /* * Pass the C string to the system() function and return the exit code * of the command as the result of system(). *//* * The following code is operating-system dependent [@fsys.06]. Perform system * call. Should not get here unless system(s) is supported. */#if PORTDeliberate Syntax Error#endif /* PORT */#if AMIGA || MSDOS || OS2 || UNIX MakeInt((long)((system(systemstring) >> 8) & 0377), &Arg0);#endif /* AMIGA || MSDOS || ... */#if ATARI_ST || VMS MakeInt(system(systemstring), &Arg0);#endif /* ATARI_ST || VMS */#if HIGHC_386 || MACINTOSH /* Should not get here */#endif /* HIGHC_386 || MACINTOSH */#if MVS || VM MakeInt((long)system(systemstring), &Arg0);#endif /* MVS || VM *//* * End of operating-system specific code. */ Return; } #endif /* SystemFnc *//* * where(file) - return current offset position in file. */FncDcl(where,1) { FILE *fd; long ftell(); if (Arg1.dword != D_File) RunErr(-105, NULL); fd = BlkLoc(Arg1)->file.fd; if ((BlkLoc(Arg1)->file.status == 0)) Fail; MakeInt(ftell(fd) + 1, &Arg0); Return; } /* * write(a,b,...) - write arguments. */FncDclV(write) { register word n; char sbuf[MaxCvtLen]; FILE *f;#ifdef BadCode struct descrip temp;#endif /* BadCode */ f = stdout; ntended = 1; tended[1] = emptystr; /* * Loop through the arguments. */ for (n = 1; n <= nargs; n++) {#ifdef BadCode temp = Arg(n); /* workaround for Microsoft bug */ tended[1] = temp;#else /* BadCode */ tended[1] = Arg(n);#endif /* BadCode */ if (tended[1].dword == D_File) { /* Current argument is a file */ /* * If this is not the first argument, output a newline to the current * file and flush it. */ if (n > 1) { putc('\n', f); fflush(f); } /* * Switch the current file to the file named by the current argument * providing it is a file. tended[1] is made to be a empty string to * avoid a special case. */ if ((BlkLoc(tended[1])->file.status & Fs_Write) == 0) RunErr(213, &tended[1]); f = BlkLoc(tended[1])->file.fd; tended[1] = emptystr; } else { /* Current argument is a string */ /* * On first argument, check to be sure that &output is open * for output. */ if (n == 1 && (k_output.status & Fs_Write) == 0) RunErr(-213, NULL); /* * Convert the argument to a string, defaulting to a empty string. */ if (ChkNull(tended[1])) tended[1] = emptystr; if (cvstr(&tended[1], sbuf) == CvtFail) RunErr(109, &tended[1]); /* * Output the string. */ if (putstr(f, &tended[1]) == Failure) RunErr(-214, NULL); } } /* * Append a newline to the file and flush it. */ putc('\n', f); if (ferror(f)) RunErr(-214, NULL); fflush(f); /* * Return the last argument. */ ntended = 0; Arg(0) = Arg(n - 1); Return; } /* * writes(a,b,...) - write arguments without newline terminator. */FncDclV(writes) { register word n; char sbuf[MaxCvtLen]; FILE *f;#ifdef BadCode struct descrip temp;#endif /* BadCode */ f = stdout; ntended = 1; tended[1] = emptystr; /* * Loop through the arguments. */ for (n = 1; n <= nargs; n++) {#ifdef BadCode temp = Arg(n); /* workaround for Microsoft bug */ tended[1] = temp;#else /* BadCode */ tended[1] = Arg(n);#endif /* BadCode */ if (tended[1].dword == D_File) { /* Current argument is a file */ /* * Switch the current file to the file named by the current argument * providing it is a file. tended[1] is made to be a empty string to * avoid a special case. */ if ((BlkLoc(tended[1])->file.status & Fs_Write) == 0) RunErr(213, &tended[1]); f = BlkLoc(tended[1])->file.fd; tended[1] = emptystr; } else { /* Current argument is a string */ /* * On first argument, check to be sure that &output is open * for output. */ if (n == 1 && (k_output.status & Fs_Write) == 0) RunErr(-213, NULL); /* * Convert the argument to a string, defaulting to a empty string. */ if (ChkNull(tended[1])) tended[1] = emptystr; if (cvstr(&tended[1], sbuf) == CvtFail) RunErr(109, &tended[1]); /* * Output the string and flush the file. */ if (putstr(f, &tended[1]) == Failure) RunErr(-214, NULL);#ifndef WATERLOO_C_V3 fflush(f);#endif /* WATERLOO_C_V3 */ } } /* * Return the last argument. */ ntended = 0; Arg(0) = Arg(n - 1); Return; } #ifdef KeyboardFncs/* * getch() - return a character from console. */FncDcl(getch,0) { unsigned char c; int i; i = getch(); if (i<0) Fail; if (strreq((word)1) == Error) RunErr(0, NULL); c = (unsigned char) i; StrLoc(Arg0) = alcstr((char *)&c,(word)1); StrLen(Arg0) = 1; Return; } /* * getche() -- return a character from console with echo. */FncDcl(getche,0) { unsigned char c; int i; i = getche(); if (i<0) Fail; if (strreq((word)1) == Error) RunErr(0, NULL); c = (unsigned char) i; StrLoc(Arg0) = alcstr((char *)&c,(word)1); StrLen(Arg0) = 1; Return; } /* * kbhit() -- Check to see if there is a keyboard character waiting to * be read. */FncDcl(kbhit,0) { if (kbhit()) { Arg0 = nulldesc; Return; } else Fail; }#endif /* KeyboardFncs */ :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:fxtra.c
/* * File: fxtra.c * Contents: additional functions to extend the standard Icon repertoire. * This file includes collections of functions, such as functions specific to * MS-DOS (DosFncs). * * These collections are under the control of conditional compilation * as indicated by the symbols in parentheses. To enable a set of functions, * define the corresponding symbol in ../h/define.h. The functions themselves * are in separate files, included according to the defined symbols. */#include "::h:config.h"#include "::h:rt.h"#include "rproto.h" #ifdef DosFncs#include "fxmsdos.c"#endif /* DosFncs */#ifdef EvalTrace#include "fxtrace.c"#endif /* EvalTrace */static char junk; /* avoid empty module */ :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:idata.c
/* * Various interpreter data tables. */#include "::h:config.h"#include "::h:rt.h"#include "rproto.h"struct b_proc Bnoproc;/* * External declarations for function blocks. */char *fncnames[] = {#ifdef PreProcess/* define(FncDef,"$1"`,') *//* define(FncDefV,"$1"`,') *//* include(../h/fdefs.h) /* *//* *//* undefine(`FncDef') *//* undefine(`FncDefV') *//* */#else /* PreProcess */#define FncDef(p,n) Lit(p),#define FncDefV(p) Lit(p),#include "::h:fdefs.h"#undef FncDef#undef FncDefV#endif /* PreProcess */ 0 };int fnsize = (sizeof(fncnames) / sizeof(char*)) - 1;#ifdef PreProcess/* define(FncDef,extern struct b_proc B$1;) *//* define(FncDefV,extern struct b_proc B$1;) *//* include(../h/fdefs.h) /* *//* *//* undefine(`FncDef') *//* undefine(`FncDefV') *//* */#else /* PreProcess */#define FncDef(p,n) extern struct b_proc Cat(B,p);#define FncDefV(p) extern struct b_proc Cat(B,p);#include "::h:fdefs.h"#undef FncDef#undef FncDefV#endif /* PreProcess */#ifdef PreProcess/* define(OpDef,extern struct b_proc B$1;) *//* include(../h/odefs.h) /* *//* undefine(`OpDef') *//* */#else /* PreProcess */#define OpDef(p,n,s) extern struct b_proc Cat(B,p);#include "::h:odefs.h"#undef OpDef#endif /* PreProcess */extern struct b_proc Bbscan;extern struct b_proc Bcreate;extern struct b_proc Bescan;extern struct b_proc Bfield;extern struct b_proc Blimit;extern struct b_proc Bllist;/* * Array of addresses of function blocks. */struct b_proc *functab[] = {#ifdef PreProcess/* define(FncDef,&B$1`,') *//* define(FncDefV,&B$1`,') *//* include(../h/fdefs.h) /* *//* undefine(`FncDef') *//* undefine(`FncDefV') *//* */#else /* PreProcess */#define FncDef(p,n) Cat(&B,p),#define FncDefV(p) Cat(&B,p),#include "::h:fdefs.h"#undef FncDef#undef FncDefV#endif /* PreProcess */ 0 };int ftsize = (sizeof(functab) / sizeof(struct b_proc *)) - 1; /* * When an opcode n has a subroutine call associated with it, the * nth word here is the routine to call. */int (*optab[])() = { err,#ifdef PreProcess/* define(OpDef,O$1`,') *//* include(../h/odefs.h) /* *//* undefine(`OpDef') *//* */#else /* PreProcess */#define OpDef(p,n,s) Cat(O,p),#include "::h:odefs.h"#undef OpDef#endif /* PreProcess */ Obscan, err, err, err, err, err, Ocreate, err, err, err, err, Oescan, err, Ofield };#ifdef TraceBackstruct b_proc *opblks[] = { NULL,#ifdef PreProcess/* define(OpDef,&B$1`,') *//* include(../h/odefs.h) /* *//* undefine(`OpDef') *//* */#else /* PreProcess */#define OpDef(p,n,s) Cat(&B,p),#include "::h:odefs.h"#undef OpDef#endif /* PreProcess */ &Bbscan, NULL, NULL, NULL, NULL, NULL, &Bcreate, NULL, NULL, NULL, NULL, &Bescan, NULL, &Bfield, NULL, NULL, NULL, NULL, NULL, &Blimit, &Bllist, NULL, NULL, NULL };#endif /* TraceBack */#ifdef StrInvoke/* * Array of names and corresponding functions. */struct pstrnm pntab[] = {#ifndef BoundFunctions#ifdef PreProcess/* define(FncDef,"$1"`,' &B$1`,') *//* define(FncDefV,"$1"`,' &B$1`,') *//* include(../h/fdefs.h) /* *//* undefine(`FncDef') *//* undefine(`FncDefV') *//* */#else /* PreProcess */#define FncDef(p,n) Lit(p), Cat(&B,p),#define FncDefV(p) Lit(p), Cat(&B,p),#include "::h:fdefs.h"#undef FncDef#undef FncDefV#endif /* PreProcess */#endif /* BoundFunctions */#ifdef PreProcess/* define(OpDef,$3`,' &B$1`,') *//* include(../h/odefs.h) /* *//* undefine(`OpDef') *//* */#else /* PreProcess */#define OpDef(p,n,s) s, Cat(&B,p),#include "::h:odefs.h"#undef OpDef#endif /* PreProcess */ 0, 0 };#endif /* StrInvoke */ /* * Structures for built-in values. Parts of some of these structures are * initialized later. Since some C compilers cannot handle any partial * initializations, all parts are initialized later if any have to be. *//* * Built-in csets *//* * &ascii; 128 bits on, second 128 bits off. */struct b_cset k_ascii = { T_Cset, 128, cset_display(~0, ~0, ~0, ~0, ~0, ~0, ~0, ~0, 0, 0, 0, 0, 0, 0, 0, 0) };/* * &cset; all 256 bits on. */struct b_cset k_cset = { T_Cset, 256, cset_display(~0, ~0, ~0, ~0, ~0, ~0, ~0, ~0, ~0, ~0, ~0, ~0, ~0, ~0, ~0, ~0) };/* * &digits; bits corrosponding to 0-9 are on. */struct b_cset k_digits = { T_Cset, 10,#if !EBCDIC cset_display(0, 0, 0, 0x3ff, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0)#else /* !EBCDIC */ cset_display(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0x3ff)#endif /* !EBCDIC */ };/* * Cset for &lcase; bits corresponding to lowercase letters are on. */struct b_cset k_lcase = { T_Cset, 26,#if !EBCDIC cset_display(0, 0, 0, 0, 0, 0, ~01, 03777, 0, 0, 0, 0, 0, 0, 0, 0)#else /* !EBCDIC */ cset_display(0, 0, 0, 0, 0, 0, 0, 0, 0x3fe, 0x3fe, 0x3fc, 0, 0, 0, 0, 0)#endif /* !EBCDIC */ };/* * &ucase; bits corresponding to uppercase characters are on. */struct b_cset k_ucase = { T_Cset, 26,#if !EBCDIC cset_display(0, 0, 0, 0, ~01, 03777, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0)#else /* !EBCDIC */ cset_display(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0x3fe, 0x3fe, 0x3fc, 0)#endif /* !EBCDIC */ };/* * &letters; bits corresponding to letters are on. */struct b_cset k_letters = { T_Cset, 52,#if !EBCDIC cset_display(0, 0, 0, 0, ~01, 03777, ~01, 03777, 0, 0, 0, 0, 0, 0, 0, 0)#else /* !EBCDIC */ cset_display(0, 0, 0, 0, 0, 0, 0, 0, 0x3fe, 0x3fe, 0x3fc, 0, 0x3fe, 0x3fe, 0x3fc, 0)#endif /* !EBCDIC */ };/* * Built-in files. */struct b_file k_errout = {T_File, NULL, Fs_Write}; /* &errout */struct b_file k_input = {T_File, NULL, Fs_Read}; /* &input */struct b_file k_output = {T_File, NULL, Fs_Write}; /* &outout *//* * Keyword trapped variables. */struct b_tvkywd tvky_err = {T_Tvkywd, putint, {D_Integer}}; /* &error */struct b_tvkywd tvky_pos = {T_Tvkywd, putpos, {D_Integer}}; /* &pos */struct b_tvkywd tvky_ran = {T_Tvkywd, putint, {D_Integer}}; /* &random */struct b_tvkywd tvky_sub = {T_Tvkywd, putsub}; /* &subject */struct b_tvkywd tvky_trc = {T_Tvkywd, putint, {D_Integer}}; /* &trace *//* * Various constant descriptors. */struct descrip blank; /* one-character blank string */struct descrip emptystr; /* zero-length empty string */struct descrip errout = {D_File}; /* &errout */struct descrip input = {D_File}; /* &input */struct descrip lcase; /* string of lowercase letters */struct descrip letr; /* "r" */struct descrip nulldesc = {D_Null}; /* null value */struct descrip onedesc = {D_Integer}; /* integer 1 */struct descrip ucase; /* string of uppercase letters */struct descrip zerodesc = {D_Integer}; /* integer 0 *//* * The tended descriptors. */struct descrip tended[6]; /* * Run-time error numbers and text. */struct errtab errtab[] = { 101er expected", 102, "numeric expected", 103, "string expected", 104, "cset expected", 105, "file expected", 106, "procedure or integer expected", 107, "record expected", 108, "list expected", 109, "string or file expected", 110, "string or list expected", 111, "variable expected", 112, "invalid type to size operation", 113, "invalid type to random operation", 114, "invalid type to subscript operation", 115, "list, set, or table expected", 116, "invalid type to element generator", 117, "missing main procedure", 118, "co-expression expected", 119, "set expected", 120, "cset or set expected", 121, "function not supported", 122, "set or table expected", 123, "invalid type", 124, "table expected", 201, "division by zero", 202, "remaindering by zero", 203, "integer overflow", 204, "real overflow, underflow, or division by zero", 205, "value out of range", 206, "negative first argument to real exponentiation", 207, "invalid field name", 208, "second and third arguments to map of unequal length", 209, "invalid second argument to open", 210, "non-ascending arguments to detab/entab", 211, "by value equal to zero", 212, "attempt to read file not open for reading", 213, "attempt to write file not open for writing", 214, "input/output error", 215, "attempt to refresh &main", 216, "external function not found", 301, "evaluation stack overflow", 302, "system stack overflow", 303, "inadequate space for evaluation stack",#ifdef FixedRegions 304, "inadequate space in qualifier list",#endif /* FixedRegions */ 305, "inadequate space for static allocation", 306, "inadequate space in string region", 307, "inadequate space in block region", 308, "system stack overflow in co-expression",#if VMS 351, "insufficient MAXMEM limit",#endif /* VMS */#ifndef Coexpr 401, "co-expressions not implemented",#endif /* Coexpr */ 500, "program malfunction", /* for use by runerr() *//* * End of operating-system specific code. */ 0, "" }; :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:imain.c
/* * Main program, initialization, termination, and such. */#include <math.h>#include "::h:config.h"#include "::h:rt.h"#include "rproto.h"#include "::h:version.h"#include "::h:header.h"#include "::h:opdefs.h"#include <ctype.h>/* * Prototype. */hidden novalue env_err Params((char *msg,char *name,char *val));/* * The following code is operating-system dependent [@imain.01]. Include files * and declarations that are system-dependent. */#if PORT#include <signal.h> /* probably needs something more */Deliberate Syntax Error#endif /* PORT */#if AMIGA#include <signal.h>#include <fcntl.h>int chkbreak; /* if nonzero, check for ^C */#endif /* AMIGA */#if ATARI_ST#include <fcntl.h>#endif /* ATARI_ST */#if HIGHC_386#include <system.cf>int _fmode = 0; /* force CR-LF on std.. files */#endif /* HIGHC_386 */#if MACINTOSH#include <signal.h>#if MPW#include <Types.h>#include <Events.h>#include <FCntl.h>#include <SANE.h>#include <CursorCtl.h>int NoOptions = 0;#endif /* MPW */#endif /* MACINTOSH */#if MSDOS#if !MWC#include <fcntl.h>#include <signal.h>#endif /* !MWC */#if MICROSOFT#include <fcntl.h>#include <signal.h>#endif /* MICROSOFT */#endif /* MSDOS */#if MVS || VM#include <signal.h>#endif /* MVS || VM */#if OS2#include <fcntl.h>#include <signal.h>#endif /* OS2 */#if UNIX#include <signal.h>#endif /* UNIX */#if VMS#include <types.h>#endif /* VMS */static char icodebuf[BUFSIZ];/* * End of operating-system specific code. */#ifdef IconAlloc#define malloc mem_alloc#endif /* IconAlloc */#ifndef MaxHeader#define MaxHeader MaxHdr#endif /* MaxHeader *//* * A number of important variables follow. */static struct b_coexpr *mainhead; /* &main */extern struct errtab errtab[]; /* error numbers and messages */#ifdef TraceBackextern struct b_proc *opblks[];extern word lastop; /* last op-code */extern dptr xargp;extern word xnargs; /* number of arguments */#endif /* TraceBack */#ifdef EvalTraceword lineno = 0; /* source line number */word colmno = 0; /* source column number */#endif /* EvalTrace */#ifdef DumpIstreamFILE *imons;#endif /* DumpIstream */#ifdef DumpIcount#define MaxIcode 100FILE *imonc;long icode[MaxIcode];#endif /* DumpIcount */#ifdef WATERLOO_C_V3_0extern int *cw3defect;#endif /* WATERLOO_C_V3_0 */#ifdef IconCallingint IDepth = 0; /* depth of icon_call calls */int call_error = 0; /* called procedure not found */int interp_status; /* interpreter status */#endif /* IconCalling */int set_up = 0; /* initialization switch */int k_level = 0; /* &level */int k_errornumber = 0; /* &errornumber */char *k_errortext = ""; /* &errortext */struct descrip k_errorvalue; /* &errorvalue */struct descrip k_main; /* &main */char *code; /* interpreter code buffer */word *records; /* pointer to record procedure blocks */word *ftabp; /* pointer to record/field table */dptr fnames, efnames; /* pointer to field names */dptr globals, eglobals; /* pointer to global variables */dptr gnames, egnames; /* pointer to global variable names */dptr statics, estatics; /* pointer to static variables */char *strcons; /* pointer to string constant table */struct ipc_fname *filenms, *efilenms; /* pointer to ipc/file name table */struct ipc_line *ilines, *elines; /* pointer to ipc/line number table */#ifdef TallyOptword tallybin[16]; /* counters for tallying */int tallyopt = 0; /* want tally results output? */#endif /* TallyOpt */word mstksize = MStackSize; /* initial size of main stack */word stksize = StackSize; /* co-expression stack size */struct b_coexpr *stklist; /* base of co-expression block list */word statsize = MaxStatSize; /* size of static region */word statincr = MaxStatSize/4; /* increment for static region */char *statbase = NULL; /* start of static space */char *statend; /* end of static space */char *statfree; /* static space free pointer */word ssize = MaxStrSpace; /* initial string space size (bytes) */char *strbase; /* start of string space */char *strend; /* end of string space */char *strfree; /* string space free pointer */char *currend = NULL; /* current end of memory region */word abrsize = MaxAbrSize; /* initial size of allocated block region (bytes) */char *blkbase; /* start of block region */char *blkend; /* end of allocated blocks */char *blkfree; /* block region free pointer */#ifdef FixedRegionsword qualsize = QualLstSize; /* size of quallist for fixed regions */#endif /* FixedRegions */uword statneed; /* stated need for static space */uword strneed; /* stated need for string space */uword blkneed; /* stated need for block space */int dodump; /* if nonzero, core dump on error */int noerrbuf; /* if nonzero, do not buffer stderr */struct descrip k_current; /* current expression stack pointer */struct descrip maps2; /* second cached argument of map */struct descrip maps3; /* third cached argument of map */int ntended = 0; /* number of active tended descrips */long starttime; /* start time of job in milliseconds */#ifdef ExecImagesint dumped = 0; /* non-zero if reloaded from dump */#endif /* ExecImages */word *stack; /* Interpreter stack */word *stackend; /* End of interpreter stack *//* * Initial icode sequence. This is used to invoke the main procedure with one * argument. If main returns, the Op_Quit is executed. */word istart[3];int mterm = Op_Quit;#ifdef IconCallingint fterm = Op_FQuit;#endif /* IconCalling */ #ifndef IconCallingnovalue main(argc, argv)int argc;char **argv; { int i, slen; ipc.opnd = NULL; /* * Setup Icon interface. It's done this way to avoid duplication * of code, since the same thing has to be done if calling Icon * is enabled. See istart.c. */ icon_setup(argc, argv, &i); #if MACINTOSH && MPW if (i < 0) { argc++; argv--; i++; } #endif /* MACINTOSH && MPW */ while (i--) { /* skip option arguments */ argc--; argv++; } if (!argc) error("no icode file specified"); /* * Call icon_init with the name of the icode file to execute. [[I?]] */ icon_init(argv[1]); /* * Point sp at word after b_coexpr block for &main, point ipc at initial * icode segment, and clear the gfp. */ stackend = stack + mstksize/WordSize; sp = stack + Wsizeof(struct b_coexpr); ipc.opnd = istart; *ipc.op++ = Op_Invoke; /* [[I?]] */ *ipc.opnd++ = 1;#ifdef WATERLOO_C_V3_0 /* * Workaround for compiler bug. */ cw3defect = ipc.op; *cw3defect = Op_Quit;#else /* WATERLOO_C_V3_0 */ *ipc.op = Op_Quit;#endif /* WATERLOO_C_V3_0 */ ipc.opnd = istart; gfp = 0; /* * Set up expression frame marker to contain execution of the * main procedure. If failure occurs in this context, control * is transferred to mterm, the address of an Op_Quit. */ efp = (struct ef_marker *)(sp); efp->ef_failure.op = &mterm; efp->ef_gfp = 0; efp->ef_efp = 0; efp->ef_ilevel = 1; sp += Wsizeof(*efp) - 1; pfp = 0; ilevel = 0; /* * The first global variable holds the value of "main". If it * is not of type procedure, this is noted as run-time error 117. * Otherwise, this value is pushed on the stack. */ if (globals[0].dword != D_Proc) fatalerr(-117, NULL); PushDesc(globals[0]); /* * Main is to be invoked with one argument, a list of the command * line arguments. The command line arguments are pushed on the * stack as a series of descriptors and llist is called to create * the list. The null descriptor first pushed serves as Arg0 for * Ollist and receives the result of the computation. */ PushNull; argp = (dptr)(sp - 1); for (i = 2; i < argc; i++) { slen = strlen(argv[i]); strreq((word)slen); PushVal(slen); PushAVal(alcstr(argv[i],(word)slen)); } Ollist(argc - 2, argp); sp = (word *)argp + 1; argp = 0; set_up = 1; /* post fact that iconx is initialized */ /* * Start things rolling by calling interp. This call to interp * returns only if an Op_Quit is executed. If this happens, * c_exit() is called to wrap things up. */ interp(0,(dptr)NULL); c_exit(NormalExit);}#endif /* IconCalling */ #ifdef IconCallingdptr icon_call(pname, argc, dargv)char *pname;int argc;dptr dargv;{ int i; dptr retdesc; struct descrip pd; if (IDepth == 0) { /* * Perform first-time initializations. * Point sp at word after b_coexpr block for &main, point ipc at initial * icode segment, and clear the gfp. */ stackend = stack + mstksize/WordSize; sp = stack + Wsizeof(struct b_coexpr); sp--; /* point at last thing on stack, not beyond it */ interp_status = 0; argp = 0; pfp = 0; ilevel = 0; } /* * Point sp at word after b_coexpr block for &main, point ipc at initial * icode segment, and clear the gfp. */ ipc.opnd = istart; *ipc.op++ = Op_Invoke; *ipc.opnd++ = argc; /* number of arguments for call */#ifdef WATERLOO_C_V3_0 /* * Workaround for compiler bug. */ cw3defect = ipc.op; *cw3defect = Op_Quit;#else /* WATERLOO_C_V3_0 */ *ipc.op = Op_Quit;#endif /* WATERLOO_C_V3_0 */ ipc.opnd = istart; gfp = 0; /* * Set up expression frame marker to contain execution of the * main procedure. If failure occurs in this context, control * is transferred to fterm, the address of an Op_FQuit. */ efp = (struct ef_marker *)(sp + 1); efp->ef_failure.op = &fterm; /* signals a failure to interp */ efp->ef_gfp = 0; efp->ef_efp = 0; efp->ef_ilevel = ilevel + 1; sp += Wsizeof(*efp); /* * "main" is no longer the default starting procedure. * Use procedure named pname as the main (starting) procedure. */ if (getvar(pname,&pd) == Failure) { fprintf(stderr, "Icon function/procedure \"%s\" not found\n", pname); fflush(stderr); call_error = 1; return (dptr)NULL; } DeRef(pd); /* get value (can't fail) */ /* * Must be of type procedure. */ if ((pd.dword != D_Proc)) { if (strcmp(pname,"main") == 0 && (pfp == 0)) fatalerr(-117, NULL); else { if (pfp == 0) fatalerr(-106, NULL); else fatalerr(106, NULL); } } PushDesc(pd); /* * The input arguments are pushed on the stack as a series * of descriptors and the indicated procedure. The procedure descriptor * is overwritten with the result of the call. */ for (i = 0; i < argc; i++) { /* i = 0, instead of 2 */ PushDesc(dargv[i]); }/* Pass on value of argp to current invocation. This will be 0 by * default on the first action, and the value of the current argp on * subsequent invocations. */ /* * Start things rolling by calling interp. This call to interp * returns only if an Op_Quit is executed. If this happens, * return the result of main. (Used to c_exit here). */ IDepth++; interp(0,(dptr)NULL); IDepth--; if (interp_status == A_Pfail_uw) return (dptr)NULL; /* failure no value */ else /* NOTE: suspension not identified */ { retdesc = (dptr)(sp - 1); sp = (word *) efp - 1; return retdesc; /* success, return top sp */ }}#endif /* IconCalling */ novalue icon_setup(argc,argv,ip)int argc;char **argv;int *ip; {#ifdef TallyOpt extern int tallyopt;#endif /* TallyOpt */ *ip = 0; /* number of arguments processed */#ifdef ExecImages if (dumped) { /* * This is a restart of a dumped interpreter. Normally, argv[0] is * iconx, argv[1] is the icode file, and argv[2:(argc-1)] are the * arguments to pass as a list to main(). For a dumped interpreter * however, argv[0] is the executable binary, and the first argument * for main() is argv[1]. The simplest way to handle this is to * back up argv to point at argv[-1] and increment argc, giving the * illusion of an additional argument at the head of the list. Note * that this argument is never referenced. */ argv--; argc++; (*ip)--; }#endif /* ExecImages */#ifdef MaxLevel maxilevel = 0; maxplevel = 0; maxsp = 0;#endif /* MaxLevel */#ifdef DumpIstream imons = fopen("icodes.mon",WriteText); if (imons == NULL) { fprintf(stderr,"cannot open icodes.mon\n"); fflush(stderr); abort(); }#endif /* DumpIstream */#ifdef DumpIcount imonc = fopen("icodec.mon",WriteText); if (imonc == NULL) { fprintf(stderr,"cannot open icodec.mon\n"); fflush(stderr); abort(); }#endif /* DumpIcount */#if VMS redirect(&argc, argv, 0);#endif /* VMS */#if MACINTOSH#if MPW InitCursorCtl(NULL); /* * To support the icode and iconx interpreter bundled together in * the same file, we might have to use this code file as the icode * file, too. We do this if the command name is not 'iconx'. */ { char *p,*q,c,fn[6]; /* * Isolate the filename from the path. */ q = strrchr(*argv,':'); if (q == NULL) q = *argv; else ++q; /* * See if it's the real iconx -- case independent compare. */ p = fn; if (strlen(q) == 5) while (c = *q++) *p++ = tolower(c); *p = '\0'; if (strcmp(fn,"iconx") != 0) { /* * This technique of shifting arguments relies on the fact that * argv[0] is never referenced, since this will make it invalid. */ --argv; ++argc; --(*ip); /* * We don't want to look for any command line options in this * case. They could interfere with options for the icon * program. */ NoOptions = 1; } }#endif /* MPW */#endif /* MACINTOSH *//* * Handle command-line options.*//* * Handle command line options.*/#if MACINTOSH && MPW if (!NoOptions)#endif /* MACINTOSH && MPW */ while ( argv[1] != 0 && *argv[1] == '-' ) { switch ( *(argv[1]+1) ) {#ifdef TallyOpt /* * Set tallying flag if -T option given */ case 'T': tallyopt = 1; break;#endif /* TallyOpt */ /* * Set stderr to new file if -e option is given. */ case 'e': { char *p; if ( *(argv[1]+2) != '\0' ) p = argv[1]+2; else { argv++; argc--; (*ip)++; p = argv[1]; if ( !p ) error("no file name given for redirection of &errout"); } if ( *p == '-' ) { /* let - be stdout *//* * The following code is operating-system dependent [@imain.02]. Redirect * stderr to stdout. */#if PORT /* may not be possible */Deliberate Syntax Error#endif /* PORT */#if AMIGA#if AZTEC_C /* * Try the same hack as above for Manx and cross fingers. * If it doesn't work, try trick used for HIGH_C, below. */ stderr->_unit = stdout->_unit; stderr->_flags = stdout->_flags;#endif /* AZTEC C */#if LATTICE /* * The following code is for Lattice 4.0. It was different * for Lattice 3.10 and probably won't work for other * C compilers. */ stderr->_file = 1; stderr->_flag = stdout->_flag;#endif /* LATTICE */#endif /* AMIGA *
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:imain.
+++++ Continued from previous card +++++
/#if ATARI_ST || MSDOS || OS2 || VMS dup2(fileno(stdout),fileno(stderr));#endif /* ATARI_ST || MSDOS || VMS */#if HIGHC_386 /* * Don't like doing this, but it seems to work. */ setbuf(stdout,NULL); setbuf(stderr,NULL); stderr->_fd = stdout->_fd; #endif /* HIGHC_386 */#if MACINTOSH#if LSC /* cannot do */#endif /* LSC */#if MPW close(fileno(stderr)); dup(fileno(stdout));#endif /* MPW */#endif /* MACINTOSH */#if MVS || VM /* May not be possible. */#endif /* MVS || VM */#if UNIX /* * This relies on the way UNIX assigns file numbers. */ close(fileno(stderr)); dup(fileno(stdout));#endif /* UNIX *//* * End of operating-system specific code. */ } else /* redirecting to named file */ if (freopen(p, "w", stderr) == NULL) syserr("Unable to redirect &errout\n"); break; } } argc--; (*ip)++; argv++; } } /* * icon_init - initialize memory and prepare for Icon execution. */novalue icon_init(name)char *name; { int n; struct header hdr; FILE *fname = NULL; word cbread, longread(); extern struct astkblk *alcactiv(); /* * Catch floating point traps and memory faults. *//* * The following code is operating-system dependent [@imain.03]. Set traps. */#if PORT /* probably needs something */Deliberate Syntax Error#endif /* PORT */#if AMIGA signal(SIGFPE,fpetrap);#endif /* AMIGA */#if ATARI_ST#endif /* ATARI_ST */#if HIGHC_386 /* signals not supported */#endif /* HIGHC_386 */#if MACINTOSH#if MPW /* This is equivalent to SIGFPE signal in the Standard Apple Numeric Environment (SANE) */ { environment e; getenvironment(&e);#ifdef mc68881 e.FPCR |= CURUNDERFLOW|CUROVERFLOW|CURDIVBYZERO;#else /* mc68881 */ e |= UNDERFLOW|OVERFLOW|DIVBYZERO;#endif /* mc68881 */ setenvironment(e);#ifdef mc68881 { static trapvector tv = {fpetrap,fpetrap,fpetrap,fpetrap,fpetrap,fpetrap,fpetrap}; settrapvector(&tv); }#else /* mc6881 */ sethaltvector((haltvector)fpetrap);#endif /* mc6881 */ }#endif /* MPW */#endif /* MACINTOSH */#if MSDOS#if LATTICE || MICROSOFT || TURBO signal(SIGFPE, fpetrap);#endif /* LATTICE || MICROSOFT || TURBO */#endif /* MSDOS */#if OS2 signal(SIGFPE, fpetrap); signal(SIGSEGV, segvtrap);#endif /* OS2 */#if MVS || VM signal(SIGPFE, fpetrap); signal(SIGFIX, fixtrap);#endif /* MVS || VM */#if UNIX || VMS signal(SIGSEGV, segvtrap);#ifdef PYRAMID { struct sigvec a; a.sv_handler = fpetrap; a.sv_mask = 0; a.sv_onstack = 0; sigvec(SIGFPE, &a, 0); sigsetmask(1 << SIGFPE); }#else /* PYRAMID */ signal(SIGFPE, fpetrap);#endif /* PYRAMID */#endif /* UNIX || VMS *//* * End of operating-system specific code. */#ifdef ExecImages /* * If reloading from a dumped out executable, skip most of init and * just set up the buffer for stderr and do the timing initializations. */ if (dumped) goto btinit;#endif /* ExecImages */ /* * Initialize data that can't be intialized statically. */ datainit(); /* * Open the icode file and read the header. [[I?]] */ if (!name) error("no interpreter file supplied"); /* * Try adding the suffix if the file name doesn't end in it. */ n = strlen(name); if (n <= 4 || (strcmp(name+n-4,IcodeSuffix) != 0) && strcmp(name+n-4,IcodeASuffix) != 0) { char tname[100]; if (strlen(name) + 5 > 100) error("icode file name too long"); strcpy(tname,name);#ifdef WATERLOO_C_V3_0 strcat(tname," ICX * (BIN"); fname = fopen(tname,"r");#else /* WATERLOO_C_V3_0 */ strcat(tname,IcodeSuffix); fname = fopen(tname,ReadBinary);#endif /* WATERLOO_C_V3_0 */ } if (fname == NULL) /* try the name as given */#ifdef WATERLOO_C_V3_0 { /* * Prevent interpretation of \n in binary files. */ char tname[100]; strcpy(tname,name); strcat(tname," (BIN"); fname = fopen(tname,"r"); }#else /* WATERLOO_C_V3_0 */ fname = fopen(name,ReadBinary);#endif /* WATERLOO_C_V3_0 */ if (fname == NULL) error("cannot open interpreter file"); setbuf(fname,icodebuf); { static char errmsg[] = "can't read interpreter file header";#ifdef Header if (fseek(fname, (long)MaxHeader, 0) == -1) error(errmsg);#endif /* Header */ if (fread((char *)&hdr, sizeof(char), sizeof(hdr), fname) != sizeof(hdr)) error(errmsg); } k_trace = hdr.trace;#ifdef EnvVars /* * Examine the environment and make appropriate settings. [[I?]] */ envset();#endif /* EnvVars */ /* * Convert stack sizes from words to bytes. */#ifndef SCO_XENIX stksize *= WordSize; mstksize *= WordSize;#else /* SCO_XENIX */ /* * This is a work-around for bad generated code for *= (as above) * produced by the SCO XENIX C Compiler for the large memory model. * It relies on the fact that WordSize is 4. */ stksize += stksize; stksize += stksize; mstksize += mstksize; mstksize += mstksize;#endif /* SCO_XENIX */#if IntBits == 16 if (mstksize > MaxBlock) fatalerr(-316, NULL); if (stksize > MaxBlock) fatalerr(-318, NULL);#endif /* IntBits == 16 */ /* * Allocate memory for various regions. */ initalloc(hdr.hsize); /* * Establish pointers to icode data regions. [[I?]] */ records = (word *)(code + hdr.records); ftabp = (word *)(code + hdr.ftab); fnames = (dptr)(code + hdr.fnames); globals = efnames = (dptr)(code + hdr.globals); gnames = eglobals = (dptr)(code + hdr.gnames); statics = egnames = (dptr)(code + hdr.statics); estatics = (dptr)(code + hdr.filenms); filenms = (struct ipc_fname *)estatics; efilenms = (struct ipc_fname *)(code + hdr.linenums); ilines = (struct ipc_line *)efilenms; elines = (struct ipc_line *)(code + hdr.strcons); strcons = (char *)elines; /* * Allocate stack and initialize &main. */ stack = (word *)malloc((msize)mstksize); if (stack == NULL) fatalerr(-303, NULL); mainhead = (struct b_coexpr *)stack; mainhead->title = T_Coexpr;#ifdef Coexpr mainhead->es_actstk = alcactiv(); if (mainhead->es_actstk == NULL) fatalerr(0, NULL); if (pushact(mainhead, mainhead) == Error) fatalerr(0, NULL);#endif /* Coexpr */ mainhead->id = 1; mainhead->size = 1; /* pretend main() does an activation */ mainhead->freshblk = nulldesc; /* &main has no refresh block. */ /* This really is a bug. */ /* * Point &main at the co-expression block for the main procedure and set * k_current, the pointer to the current co-expression, to &main. */ k_main.dword = D_Coexpr; BlkLoc(k_main) = (union block *) mainhead; k_current = k_main; /* * Read the interpretable code and data into memory. */ if ((cbread = longread(code, sizeof(char), (long)hdr.hsize, fname)) != hdr.hsize) { fprintf(stderr,"Tried to read %ld bytes of code, got %ld\n", (long)hdr.hsize,(long)cbread); error("can't read interpreter code"); } fclose(fname);/* * Make sure the version number of the icode matches the interpreter version. */ if (strcmp((char *)hdr.config,IVersion)) { fprintf(stderr,"icode version mismatch\n"); fprintf(stderr,"\ticode version: %s\n",(char *)hdr.config); fprintf(stderr,"\texpected version: %s\n",IVersion); error("cannot run"); } /* * Resolve references from icode to run-time system. */ resolve();#ifdef ExecImagesbtinit:#endif /* ExecImages *//* * The following code is operating-system dependent [@imain.04]. Allocate and * assign a buffer to stderr if possible. */#if PORT /* probably nothing */Deliberate Syntax Error#endif /* PORT */#if AMIGA || HIGHC_386 || MVS || VM /* not done */#endif /* AMIGA */#if ATARI_ST || MACINTOSH || UNIX || MSDOS || OS2 || VMS if (noerrbuf) setbuf(stderr, NULL); else { char *buf; buf = (char *)malloc((msize)BUFSIZ); if (buf == NULL) fatalerr(-305, NULL); setbuf(stderr, buf); }#endif /* ATARI_ST || MACINTOSH || UNIX ... *//* * End of operating-system specific code. */#ifdef MemMon /* * Initialize the memory monitoring system, if configured. */ MMInit(name);#endif /* MemMon */#ifdef EvalTrace /* * Initialize evaluation tracing system */ TRInit(name);#endif /* EvalTrace */ /* * Start timing execution. */ millisec(); } /* * Service routines related to getting things started. *//* * resolve - perform various fix-ups on the data read from the icode * file. */novalue resolve() { register word i; register struct b_proc *pp; register dptr dp; extern Omkrec(); extern int ftsize; extern struct b_proc *functab[]; /* * Scan the global variable array for procedures and fill in appropriate * addresses. */ for (dp = globals; dp < eglobals; dp++) { if ((*dp).dword != D_Proc) continue; /* * The second word of the descriptor for procedure variables tells * where the procedure is. Negative values are used for built-in * procedures and positive values are used for Icon procedures. */ i = IntVal(*dp); if (i < 0) { /* * *dp names a built-in function, negate i and use it as an index * into functab to get the location of the procedure block. */ i = -i; if (i > ftsize) { *dp = nulldesc; /* undefined, set to &null */ continue; } BlkLoc(*dp) = (union block *)functab[i-1]; } else { /* * *dp names an Icon procedure or a record. i is an offset to * location of the procedure block in the code section. Point * pp at the block and replace BlkLoc(*dp). */ pp = (struct b_proc *)(code + i); BlkLoc(*dp) = (union block *)pp; /* * Relocate the address of the name of the procedure. */ StrLoc(pp->pname) = strcons + (uword)StrLoc(pp->pname); if (pp->ndynam == -2) /* * This procedure is a record constructor. Make its entry point * be the entry point of Omkrec(). */ pp->entryp.ccode = Omkrec; else { /* * This is an Icon procedure. Relocate the entry point and * the names of the parameters, locals, and static variables. */ pp->entryp.icode = code + pp->entryp.ioff; for (i = 0; i < abs((int)pp->nparam)+pp->ndynam+pp->nstatic; i++) StrLoc(pp->lnames[i]) = strcons + (uword)StrLoc(pp->lnames[i]); }#ifndef BoundFunctions }#endif /* BoundFunctions */ } /* * Relocate the names of the fields. */ for (dp = fna< efnames; dp++) StrLoc(*dp) = strcons + (uword)StrLoc(*dp); /* * Relocate the names of the global variables. */ for (dp = gnames; dp < egnames; dp++) StrLoc(*dp) = strcons + (uword)StrLoc(*dp); }#ifdef EnvVars/* * Check for environment variables that Icon uses and set system * values as is appropriate. */novalue envset() { register char *p; if ((p = getenv("NOERRBUF")) != NULL) noerrbuf++; env_int("TRACE", &k_trace, 0, (uword)0); env_int("COEXPSIZE", &stksize, 1, (uword)MaxUnsigned); env_int("STRSIZE", &ssize, 1, (uword)MaxBlock); env_int("HEAPSIZE", &abrsize, 1, (uword)MaxBlock); env_int("BLOCKSIZE", &abrsize, 1, (uword)MaxBlock); /* synonym */ env_int("BLKSIZE", &abrsize, 1, (uword)MaxBlock); /* synonym */ env_int("STATSIZE", &statsize, 1, (uword)MaxBlock); env_int("STATINCR", &statincr, 1, (uword)MaxBlock); env_int("MSTKSIZE", &mstksize, 1, (uword)MaxUnsigned);#ifdef FixedRegions env_int("QLSIZE", &qualsize, 1, (uword)MaxBlock);#endif /* FixedRegions *//* * The following code is operating-system dependent [@imain.05]. Check any * system-dependent environment variables. */#if PORT /* nothing to do */Deliberate Syntax Error#endif /* PORT */#if AMIGA if ((p = getenv("CHECKBREAK")) != NULL) chkbreak++;#endif /* AMIGA */#if ATARI_ST || HIGHC_386 || MACINTOSH || MSDOS || MVS || OS2 || UNIX || VM /* nothing to do */#endif /* ATARI_ST || HIGHC_386 || ... */#if VMS { extern word memsize; env_int("MAXMEM", &memsize, 1, MaxBlock); }#endif /* VMS *//* * End of operating-system specific code. */ if ((p = getenv("ICONCORE")) != NULL && *p != '\0') {/* * The following code is operating-system dependent [@imain.06]. Set trap to * give dump on abnormal termination if ICONCORE is set. */#if PORT /* can't handle */Deliberate Syntax Error#endif /* PORT */#if AMIGA || ATARI_ST || HIGHC_386 || MACINTOSH /* can't handle */#endif /* AMIGA || ATARI_ST || ... */#if MSDOS#if LATTICE || TURBO signal(SIGFPE, SIG_DFL);#endif /* LATTICE || TURBO */#endif /* MSDOS */#if MVS || VM /* Really nothing to do. */#endif /* MVS || VM */#if OS2 signal(SIGSEGV, SIG_DFL); signal(SIGFPE, SIG_DFL);#endif /* OS2 */#if UNIX || VMS signal(SIGSEGV, SIG_DFL);#endif /* UNIX || VMS *//* * End of operating-system specific code. */ dodump++; } }static novalue env_err(msg, name, val)char *msg;char *name;char *val;{ char msg_buf[100]; strncpy(msg_buf, msg, 99); strncat(msg_buf, ": ", 99 - strlen(msg_buf)); strncat(msg_buf, name, 99 - strlen(msg_buf)); strncat(msg_buf, "=", 99 - strlen(msg_buf)); strncat(msg_buf, val, 99 - strlen(msg_buf)); error(msg_buf);}/* * env_int - get the value of an integer-valued environment variable. */novalue env_int(name, variable, non_neg, limit)char *name;word *variable;int non_neg;uword limit;{ char *value; char *s; register uword n = 0; register uword d; int sign = 1; if ((value = getenv(name)) == NULL || *value == '\0') return; s = value; if (*s == '-') { if (non_neg) env_err("environment variable out of range", name, value); sign = -1; ++s; } else if (*s == '+') ++s; while (isdigit(*s)) { d = *s++ - '0'; /* * See if 10 * n + d > limit, but do it so there can be no overflow. */ if ((d > (uword)(limit / 10 - n) * 10 + limit % 10) && (limit > 0)) env_err("environment variable out of range", name, value); n = n * 10 + d; } if (*s != '\0') env_err("environment variable not numeric", name, value); *variable = sign * n;}#endif /* EnvVars */ /* * Termination routines. *//* * Produce run-time error 204 on floating-point traps. */novalue fpetrap() { fatalerr(-204, NULL); }/* * Produce run-time error 320 on ^C interrupts. Not used at present, * since malfunction may occur during traceback. */novalue inttrap() { fatalerr(-320, NULL); } /* * Produce run-time error 302 on segmentation faults. */novalue segvtrap() { fatalerr(-302, NULL); } #if MVS || VMnovalue fixtrap() { fatalerror(-203, NUL
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:imain.
+++++ Continued from previous card +++++
L); }#endif /* MVS || VM */ /* * error - print error message s; used only in startup code. */novalue error(s)char *s; { fprintf(stderr, "error in startup code\n%s\n", s); fflush(stderr); if (dodump) abort(); c_exit(ErrorExit); } /* * syserr - print s as a system error. */novalue syserr(s)char *s; { if (pfp != 0) fprintf(stderr, "System error at line %ld in %s\n%s\n", (long)findline(ipc.opnd), findfile(ipc.opnd), s); else fprintf(stderr, "System error in startup code\n%s\n", s); fflush(stderr); if (dodump) abort(); c_exit(ErrorExit); } /* * runerr - print message corresponding to error |n|; if n > 0, * print it as the offending value. */novalue runerr(n, v)register int n;dptr v; { register struct errtab *p; if (n != 0) { k_errornumber = n; if (n > 0) k_errorvalue = *v; else k_errorvalue = nulldesc; } /* * Take absolute value of error number */ n = (k_errornumber > 0 ? k_errornumber : -k_errornumber); k_errortext = ""; for (p = errtab; p->err_no > 0; p++) if (p->err_no == n) { k_errortext = p->errmsg; break; } if (pfp != 0) { if (k_error == 0) { fprintf(stderr, "Run-time error %d\nFile %s; Line %ld\n", n, findfile(ipc.opnd), (long)findline(ipc.opnd)); } else { k_error--; return; } } else fprintf(stderr, "Run-time error %d in startup code\n", n); fprintf(stderr, "%s\n", k_errortext); if (k_errornumber > 0) { fprintf(stderr, "offending value: "); outimage(stderr, &k_errorvalue, 0); putc('\n', stderr); } fflush(stderr);#ifdef MemMon { char buf[40]; sprintf(buf,"Run-time error %d: ",n); MMTerm(buf,k_errortext); }#endif /* MemMon */#ifdef EvalTrace { char buf[40]; sprintf(buf,"Run-time error %d: ",n); TRTerm(buf,k_errortext); }#endif /* EvalTrace */#ifdef TraceBack if (pfp == 0) { /* skip if start-up problem */ if (dodump) abort(); c_exit(ErrorExit); } { struct pf_marker *origpfp = pfp; dptr arg; struct b_proc *cproc; inst cipc; fprintf(stderr, "Trace back:\n"); /* * Chain back through the procedure frame markers, looking for the * first one, while building a foward chain of pointers through * the expression frame pointers. */ for (pfp->pf_efp = NULL; pfp->pf_pfp != NULL; pfp = pfp->pf_pfp) { (pfp->pf_pfp)->pf_efp = (struct ef_marker *)pfp; } /* Now start from the base procedure frame marker, producing a listing * of the procedure calls up through the last one. */ while (pfp) { arg = &((dptr)pfp)[-(pfp->pf_nargs) - 1]; cproc = (struct b_proc *)BlkLoc(arg[0]); /* * The ipc in the procedure frame points after the "invoke n". */ cipc = pfp->pf_ipc; --cipc.opnd; --cipc.op; xtrace(cproc, pfp->pf_nargs, &arg[0], findline(cipc.opnd), findfile(cipc.opnd)); /* * On the last call, show both the call and the offending expression. */ if (pfp == origpfp) { ttrace(); break; } pfp = (struct pf_marker *)(pfp->pf_efp); } }#endif /* TraceBack */ if (dodump) abort(); c_exit(ErrorExit); } /* * c_exit(i) - flush all buffers and exit with status i. */novalue c_exit(i)int i;{#ifdef MemMon MMTerm("","");#endif /* MemMon */#ifdef EvalTrace TRTerm("","");#endif /* EvalTrace */#ifdef TallyOpt { int j; if (tallyopt) { fprintf(stderr,"tallies: "); for (j=0; j<16; j++) fprintf(stderr," %ld", (long)tallybin[j]); fprintf(stderr,"\n"); } }#endif /* TallyOpt */ exit(i);} /* * err() is called if an erroneous situation occurs in the virtual * machine code. It is typed as int to avoid declaration problems * elsewhere. */int err(){ syserr("call to 'err'\n"); return 1; /* unreachable; make compilers happy */} novalue fatalerr(n, v)int n;dptr v; { k_error = 0; runerr(n, v); } novalue datainit() { /* * Initializations that cannot be performed statically (at least for * some compilers). [[I?]] */ k_errout.fd = stderr; k_errout.fname.dword = 7; StrLoc(k_errout.fname) = "&errout"; k_errout.status = Fs_Write; k_input.fd = stdin; k_input.fname.dword = 6; StrLoc(k_input.fname) = "&input"; k_input.status = Fs_Read; k_output.fd = stdout; k_output.fname.dword = 7; StrLoc(k_output.fname) = "&output"; k_output.status = Fs_Write; IntVal(tvky_pos.kyval) = 1; StrLen(tvky_pos.kyname) = 4; StrLoc(tvky_pos.kyname) = "&pos"; IntVal(tvky_ran.kyval) = 0; StrLen(tvky_ran.kyname) = 7; StrLoc(tvky_ran.kyname) = "&random"; StrLen(tvky_sub.kyval) = 0; StrLoc(tvky_sub.kyval) = ""; StrLen(tvky_sub.kyname) = 8; StrLoc(tvky_sub.kyname) = "&subject"; IntVal(tvky_trc.kyval) = 0; StrLen(tvky_trc.kyname) = 6; StrLoc(tvky_trc.kyname) = "&trace"; IntVal(tvky_err.kyval) = 0; StrLen(tvky_err.kyname) = 6; StrLoc(tvky_err.kyname) = "&error"; StrLen(blank) = 1; StrLoc(blank) = " "; StrLen(emptystr) = 0; StrLoc(emptystr) = ""; BlkLoc(errout) = (union block *) &k_errout; BlkLoc(input) = (union block *) &k_input; StrLen(lcase) = 26; StrLoc(lcase) = "abcdefghijklmnopqrstuvwxyz"; StrLen(letr) = 1; StrLoc(letr) = "r"; IntVal(nulldesc) = 0; k_errorvalue = nulldesc; IntVal(onedesc) = 1; StrLen(ucase) = 26; StrLoc(ucase) = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; IntVal(zerodesc) = 0; maps2 = nulldesc; maps3 = nulldesc;#ifdef MultipleRuns mstksize = MStackSize; /* initial size of main stack */ stksize = StackSize; /* co-expression stack size */ ssize = MaxStrSpace; /* initial string space size (bytes) */ abrsize = MaxAbrSize; /* initial size of allocated block region (bytes) */ #ifdef FixedRegions qualsize = QualLstSize; /* size of quallist for fixed regions */#endif /* FixedRegions */ ntended = 0; /* number of active tended descrips */ dodump = 0; /* produce dump on error */ mterm = Op_Quit;#ifdef IconCalling fterm = Op_FQuit;#endif /* IconCalling */#ifdef ExecImages dumped = 0; /* This is a dumped image. */#endif /* ExecImages */ /* In module interp.c: */ pfp = 0; /* Procedure frame pointer */ sp = NULL; /* Stack pointer */ /* In module rmemmgt.c: */ coexp_ser = 2; list_ser = 1; set_ser = 1; table_ser = 1; coll_stat = 0; coll_str = 0; coll_blk = 0; coll_tot = 0; #endif /* MultipleRuns */ } :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:interp.c
/* * The intepreter proper. */#include "::h:config.h"#include "::h:rt.h"#include "rproto.h"#include "::h:opdefs.h"extern fptr fncentry[];#ifdef DumpIstreamextern FILE *imons;#endif /* DumpIstream */#ifdef DumpIcountextern FILE *imonc;#endif /* DumpIcount *//* * The following code is operating-system dependent [@interp.01]. Declarations * and include files. */#if PORTDeliberate Syntax Error#endif /* PORT */#if ATARI_ST || HIGHC_386 || MSDOS || MVS || OS2 || UNIX || VM || VMS /* nothing needed */#endif /* ATARI_ST || ... */#if AMIGA#include <fcntl.h>#include <ios1.h>extern int chkbreak;#endif /* AMIGA */#if MACINTOSH#if MPW#include <CursorCtl.h>#define CURSORINTERVAL 1000#endif MPW#endif /* MACINTOSH *//* * End of operating-system specific code. */#ifdef EvalTraceextern word lineno; /* source line number */extern word colmno; /* source column number */#endif /* EvalTrace *//* * Istate variables. */struct pf_marker *pfp = 0; /* Procedure frame pointer */struct ef_marker *efp; /* Expression frame pointer */struct gf_marker *gfp; /* Generator frame pointer */inst ipc; /* Interpreter program counter */dptr argp; /* Pointer to argument zero */word *sp = NULL; /* Stack pointer */#ifdef WATERLOO_C_V3_0int *cw3defect;#endif /* WATERLOO_C_V3_0 */#ifdef IconCallingextern int interp_status; /* interpreter status */extern int IDepth; /* depth of icon_call */#endif /* IconCalling */#ifdef Pollingextern int pollctr;#endif /* Polling */int ilevel; /* Depth of recursion in interp() */word lastop; /* Last operator evaluated */struct descrip list_tmp; /* list argument to Op_Apply */#ifdef MaxLevelint maxilevel; /* Maximum ilevel */int maxplevel; /* Maximum &level */word *maxsp; /* Maximum interpreter sp */#endif /* MaxLevel *//* * Descriptor to hold result for eret across potential interp unwinding. */struct descrip eret_tmp;/* * Last co-expression action. */int coexp_act;#ifdef TraceBackdptr xargp;word xnargs;#endif /* TraceBack *//* * Macros for use inside the main loop of the interpreter. *//* * Setup_Op sets things up for a call to the C function for an operator. */#ifdef TraceBack#define Setup_Op(nargs) \ rargp = (dptr)(rsp - 1) - nargs; \ xargp = rargp; \ ExInterp;#else /* TraceBack */#define Setup_Op(nargs) \ rargp = (dptr)(rsp - 1) - nargs; \ ExInterp;#endif /* TraceBack */#define Call_Cond if ((*(optab[lastop]))(rargp) == A_Failure) goto efail; \ else \ rsp = (word *) rargp + 1;/* * Call_Gen - Call a generator. A C routine associated with the * current opcode is called. When it when it terminates, control is * passed to C_rtn_term to deal with the termination condition appropriately. */#define Call_Gen signal = (*(optab[lastop]))(rargp); \ goto C_rtn_term;/* * GetWord fetches the next icode word. PutWord(x) stores x at the current * icode word. */#define GetWord (*ipc.opnd++)#define PutWord(x) ipc.opnd[-1] = (x)#define GetOp (word)(*ipc.op++)#define PutOp(x) ipc.op[-1] = (x)/* * DerefArg(n) dereferences the nth argument. */#define DerefArg(n) if (DeRef(rargp[n]) == Error) {\ runerr(0, NULL);\ goto efail;}/* * For the sake of efficiency, the stack pointer is kept in a register * variable, rsp, in the interpreter loop. Since this variable is * only accessible inside the loop, and the global variable sp is used * for the stack pointer elsewhere, rsp must be stored into sp when * the context of the loop is left and conversely, rsp must be loaded * from sp when the loop is reentered. The macros ExInterp and EntInterp, * respectively, handle these operations. Currently, this register/global * scheme is only used for the stack pointer, but it can be easily extended * to other variables. */#define ExInterp sp = rsp;#define EntInterp rsp = sp;/* * Inside the interpreter loop, PushDesc, PushNull, PushAVal, and * PushVal use rsp instead of sp for efficiency. */#undef PushDesc#undef PushNull#undef PushVal#undef PushAVal#define PushDesc(d) {*++rsp=((d).dword); *++rsp=((d).vword.integr);}#define PushNull {*++rsp = D_Null; *++rsp = 0;}#define PushVal(v) {*++rsp = (word)(v);}/* * The following code is operating-system dependent [@interp.02]. Define * PushAVal for computers that store longs and pointers differently. */#if PORT#define PushAVal(x) PushVal(x)Deliberate Syntax Error#endif /* PORT */#if MSDOS || OS2#define PushAVal(x) {rsp++; \ stkword.stkadr = (char *)(x); \ *rsp = stkword.stkint; \ }#endif /* MSDOS || OS2 */#if AMIGA || ATARI_ST || HIGHC_386 || MACINTOSH || MVS || UNIX || VM || VMS#define PushAVal(x) PushVal(x)#endif /* AMIGA || ATARI_ST || HIGHC_386 ... *//* * End of operating-system specific code. *//* * The main loop of the interpreter. */int interp(fsig,cargp)int fsig;dptr cargp; { register word opnd; register word *rsp; register dptr rargp; register struct ef_marker *newefp; register struct gf_marker *newgfp; register word *wd; register word *firstwd, *lastwd; word *oldsp; int type, signal, args; extern int (*optab[])(); extern struct astkblk *alcactiv(); extern char *strcons; struct b_proc *bproc;#ifdef TallyOpt extern word tallybin[];#endif /* TallyOpt */ /* * Make a stab at catching interpreter stack overflow. This does * nothing for invocation in a co-expression other than &main. */ if (BlkLoc(k_current) == BlkLoc(k_main) && ((char *)sp + PerilDelta) > (char *)stackend) fatalerr(-301, NULL);#ifdef Polling pollctr--; if (!pollctr) pollctr = pollevent();#endif /* Polling */ ilevel++;#ifdef MaxLevel if (ilevel > maxilevel) maxilevel = ilevel;#endif /* MaxLevel */ EntInterp; if (fsig == G_Csusp) { oldsp = rsp; /* * Create the generator frame. */ newgfp = (struct gf_marker *)(rsp + 1); newgfp->gf_gentype = G_Csusp; newgfp->gf_gfp = gfp; newgfp->gf_efp = efp; newgfp->gf_ipc = ipc; rsp += Wsizeof(struct gf_smallmarker); /* * Region extends from first word after the marker for the generator * or expression frame enclosing the call to the now-suspending * routine to the first argument of the routine. */ if (gfp != 0) { if (gfp->gf_gentype == G_Psusp) firstwd = (word *)gfp + Wsizeof(*gfp); else firstwd = (word *)gfp + Wsizeof(struct gf_smallmarker); } else firstwd = (word *)efp + Wsizeof(*efp); lastwd = (word *)cargp + 1; /* * Copy the portion of the stack with endpoints firstwd and lastwd * (inclusive) to the top of the stack. */ for (wd = firstwd; wd <= lastwd; wd++) *++rsp = *wd; gfp = newgfp; }/* * Top of the interpreter loop. */ for (;;) {#ifdef MaxLevel if (sp > maxsp) maxsp = sp;#endif /* MaxLevel */ lastop = GetOp; /* Instruction fetch */#ifdef StackPic ExInterp; stkdump((int)lastop); EntInterp;#endif /* StackPic */#ifdef DumpIstream putc((char)lastop,imons);#endif /* DumpIstream */#ifdef DumpIcount if (lastop > MaxIcode) { fprintf(stderr,"Unexpected large opcode = %d\n",lastop); fflush(stderr); abort; } icode[lastop]++;#endif /* DumpIcount *//* * The following code is operating-system dependent [@interp.03]. Check * for external event. */#if PORTDeliberate Syntax Error#endif /* PORT */#if AMIGA ExInterp; if (chkbreak > 0) chkabort(); /* check for CTRL-C or CTRL-D break */ EntInterp;#endif /* AMIGA */#if ATARI_ST || HIGHC_386 || MSDOS || MVS || OS2 || UNIX || VM || VMS /* nothing to do */#endif /* ATARI_ST || HIGHC_386 ... */#if MACINTOSH#if MPW { static short cursorcount = CURSORINTERVAL; if (--cursorcount == 0) { RotateCursor(0); cursorcount = CURSORINTERVAL; } }#endif /* MPW */#endif /* MACINTOSH *//* * End of operating-system specific code. */ switch ((int)lastop) { /* * Switch on opcode. The cases are * organized roughly by functionality * to make it easier to find things. * For some C compilers, there may be * an advantage to arranging them by * likelihood of selection. */ /* ---Constant construction--- */ case Op_Cset: /* cset */ PutOp(Op_Acset); PushVal(D_Cset); opnd = GetWord; opnd += (word)ipc.opnd; PutWord(opnd); PushAVal(opnd); break; case Op_Acset: /* cset, absolute address */ PushVal(D_Cset); PushAVal(GetWord); break; case Op_Int: /* integer */ PushVal(D_Integer); PushVal(GetWord); break; case Op_Real: /* real */ PutOp(Op_Areal); PushVal(D_Real); opnd = GetWord; opnd += (word)ipc.opnd; PushAVal(opnd); PutWord(opnd); break; case Op_Areal: /* real, absolute address */ PushVal(D_Real); PushAVal(GetWord); break; case Op_Str: /* string */ PutOp(Op_Astr); PushVal(GetWord) opnd = (word)strcons + GetWord; PutWord(opnd); PushAVal(opnd); break; case Op_Astr: /* string, absolute address */ PushVal(GetWord); PushAVal(GetWord); break; /* ---Variable construction--- */ case Op_Arg: /* argument */ PushVal(D_Var); PushAVal(&argp[GetWord + 1]); break; case Op_Global: /* global */ PutOp(Op_Aglobal); PushVal(D_Var); opnd = GetWord; PushAVal(&globals[opnd]); PutWord((word)&globals[opnd]); break; case Op_Aglobal: /* global, absolute address */ PushVal(D_Var); PushAVal(GetWord); break; case Op_Local: /* local */ PushVal(D_Var); PushAVal(&pfp->pf_locals[GetWord]); break; case Op_Static: /* static */ PutOp(Op_Astatic); PushVal(D_Var); opnd = GetWord; PushAVal(&statics[opnd]); PutWord((word)&statics[opnd]); break; case Op_Astatic: /* static, absolute address */ PushVal(D_Var); PushAVal(GetWord); break; /* ---Operators--- */ /* Unary operators */ case Op_Compl: /* ~e */ case Op_Neg: /* -e */ case Op_Number: /* +e */ case Op_Refresh: /* ^e */ case Op_Size: /* *e */ Setup_Op(1); DerefArg(1); Call_Cond; break; case Op_Value: /* .e */ case Op_Nonnull: /* \e */ case Op_Null: /* /e */ Setup_Op(1); Call_Cond; break; case Op_Random: /* ?e */ PushNull; Setup_Op(2) Call_Cond break; /* Generative unary operators */ case Op_Tabmat: /* =e */ Setup_Op(1); DerefArg(1); Call_Gen; case Op_Bang: /* !e */ PushNull; Setup_Op(2); Call_Gen; /* Binary operators */ case Op_Cat: /* e1 || e2 */ case Op_Diff: /* e1 -- e2 */ case Op_Div: /* e1 / e2 */ case Op_Inter: /* e1 ** e2 */ case Op_Lconcat: /* e1 ||| e2 */ case Op_Minus: /* e1 - e2 */ case Op_Mod: /* e1 % e2 */ case Op_Mult: /* e1 * e2 */ case Op_Power: /* e1 ^ e2 */ case Op_Unions: /* e1 ++ e2 */ case Op_Plus: /* e1 + e2 */ case Op_Eqv: /* e1 === e2 */ case Op_Lexeq: /* e1 == e2 */ case Op_Lexge: /* e1 >>= e2 */ case Op_Lexgt: /* e1 >> e2 */ case Op_Lexle: /* e1 <<= e2 */ case Op_Lexlt: /* e1 << e2 */ case Op_Lexne: /* e1 ~== e2 */ case Op_Neqv: /* e1 ~=== e2 */ case Op_Numeq: /* e1 = e2 */ case Op_Numge: /* e1 >= e2 */ case Op_Numgt: /* e1 > e2 */ case Op_Numle: /* e1 <= e2 */ case Op_Numne: /* e1 ~= e2 */ case Op_Numlt: /* e1 < e2 */ Setup_Op(2); DerefArg(1); DerefArg(2); Call_Cond; break; case Op_Asgn: /* e1 := e2 */ Setup_Op(2); DerefArg(2); Call_Cond; break; case Op_Swap: /* e1 :=: e2 */ PushNull; Setup_Op(3); Call_Cond; break; case Op_Subsc: /* e1[e2] */ PushNull; Setup_Op(3); DerefArg(2); Call_Cond; break; /* Generative binary operators */ case Op_Rasgn: /* e1 <- e2 */ Setup_Op(2); DerefArg(2); Call_Gen; case Op_Rswap: /* e1 <-> e2 */ PushNull; Setup_Op(3); Call_Gen; /* Conditional ternary operators */ case Op_Sect: /* e1[e2:e3] */ PushNull; Setup_Op(4); DerefArg(2); DerefArg(3); Call_Cond; break; /* Generative ternary operators */ case Op_Toby: /* e1 to e2 by e3 */ Setup_Op(3); DerefArg(1); DerefArg(2); DerefArg(3); Call_Gen;#ifdef LineCodes case Op_Noop: /* no-op */#ifdef Polling pollctr--; if (!pollctr) pollctr = pollevent();#endif /* Polling */ break;#endif /* LineCodes */#ifdef EvalTrace case Op_Colm: /* source column number */ colmno = GetWord; break; case Op_Line: /* source line number */ lineno = GetWord; break;#endif /* EvalTrace */ /* ---String Scanning--- */ case Op_Bscan: /* prepare for scanning */ PushDesc(k_subject); PushVal(D_Integer); PushVal(k_pos); Setup_Op(2); signal = Obscan(2,rargp); goto C_rtn_term; case Op_Escan: /* exit from scanning */ Setup_Op(1); signal = Oescan(1,rargp); goto C_rtn_term; /* ---Other Language Operations--- */ case Op_Apply: { /* apply */ { union block *bp; int i, j; list_tmp = *(dptr)(rsp - 1); /* argument */ DeRef(list_tmp); if (list_tmp.dword != D_List) { /* be sure it's a list */ xargp = (dptr)(rsp - 3); runerr(108, &list_tmp); goto efail; } rsp -= 2; /* pop it off */ bp = BlkLoc(list args = (int)bp->list.size; for (bp = bp->list.listhead; bp != NULL; bp = bp->lelem.listnext) { for (i = 0; i < bp->lelem.nused; i++) { j = bp->lelem.first + i; if (j >= bp->lelem.nslots) j -= bp->lelem.nslots; PushDesc(bp->lelem.lslots[j]) } } goto invokej; } } case Op_Invoke: { /* invoke */ args = (int)GetWord;invokej: { int nargs; dptr carg; ExInterp; type = invoke(args, &carg, &nargs); rargp = carg; EntInterp;#ifdef MaxLevel if (k_level > maxplevel) maxplevel = k_level;#endif /* MaxLevel */ if (type == I_Fail) goto efail; if (type == I_Continue) break; else { int (*bfunc)(); bproc = (struct b_proc *)BlkLoc(*rargp); bfunc = bproc->entryp.ccode; /* ExInterp not needed since no change since last EntInterp */ if (type == I_Vararg) signal = (*bfunc)(nargs,rargp); else signal = (*bfunc)(rargp); goto C_rtn_term; } } break; } case Op_Keywd: /* keyword */ PushVal(D_Integer); PushVal(GetWord); Setup_Op(0); signal = Okeywd(0,rargp); goto C_rtn_term; case Op_Llist: /* construct list */ opnd = GetWord; Setup_Op(opnd); signal = Ollist((int)opnd,rargp); goto C_rtn_term; /* ---Marking and Unmarking--- */ case Op_Mark: /* create expression frame marker */ PutOp(Op_Amark); opnd = GetWord; opnd += (word)ipc.opnd; PutWord(opnd); newefp = (struct ef_marker *)(rsp + 1); newefp->ef_failure.opnd = (word *)o
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:interp
+++++ Continued from previous card +++++
pnd; goto mark; case Op_Amark: /* mark with absolute fipc */ newefp = (struct ef_marker *)(rsp + 1); newefp->ef_failure.opnd = (word *)GetWord;mark: newefp->ef_gfp = gfp; newefp->ef_efp = efp; newefp->ef_ilevel = ilevel; rsp += Wsizeof(*efp); efp = newefp; gfp = 0; break; case Op_Mark0: /* create expression frame with 0 ipl */mark0: newefp = (struct ef_marker *)(rsp + 1); newefp->ef_failure.opnd = 0; newefp->ef_gfp = gfp; newefp->ef_efp = efp; newefp->ef_ilevel = ilevel; rsp += Wsizeof(*efp); efp = newefp; gfp = 0; break; case Op_Unmark: /* remove expression frame */ gfp = efp->ef_gfp; rsp = (word *)efp - 1; /* * Remove any suspended C generators. */Unmark_uw: if (efp->ef_ilevel < ilevel) { --ilevel; ExInterp; return A_Unmark_uw; } efp = efp->ef_efp; break; /* ---Suspensions--- */ case Op_Esusp: { /* suspend from expression */ /* * Create the generator frame. */ oldsp = rsp; newgfp = (struct gf_marker *)(rsp + 1); newgfp->gf_gentype = G_Esusp; newgfp->gf_gfp = gfp; newgfp->gf_efp = efp; newgfp->gf_ipc = ipc; gfp = newgfp; rsp += Wsizeof(struct gf_smallmarker); /* * Region extends from first word after enclosing generator or * expression frame marker to marker for current expression frame. */ if (efp->ef_gfp != 0) { newgfp = (struct gf_marker *)(efp->ef_gfp); if (newgfp->gf_gentype == G_Psusp) firstwd = (word *)efp->ef_gfp + Wsizeof(*gfp); else firstwd = (word *)efp->ef_gfp + Wsizeof(struct gf_smallmarker); } else firstwd = (word *)efp->ef_efp + Wsizeof(*efp); lastwd = (word *)efp - 1; efp = efp->ef_efp; /* * Copy the portion of the stack with endpoints firstwd and lastwd * (inclusive) to the top of the stack. */ for (wd = firstwd; wd <= lastwd; wd++) *++rsp = *wd; PushVal(oldsp[-1]); PushVal(oldsp[0]); break; } case Op_Lsusp: { /* suspend from limitation */ struct descrip sval; /* * The limit counter is contained in the descriptor immediately * prior to the current expression frame. lval is established * as a pointer to this descriptor. */ dptr lval = (dptr)((word *)efp - 2); /* * Decrement the limit counter and check it. */ if (--IntVal(*lval) > 0) { /* * The limit has not been reached, set up stack. */ sval = *(dptr)(rsp - 1); /* save result */ /* * Region extends from first word after enclosing generator or * expression frame marker to the limit counter just prior to * to the current expression frame marker. */ if (efp->ef_gfp != 0) { newgfp = (struct gf_marker *)(efp->ef_gfp); if (newgfp->gf_gentype == G_Psusp) firstwd = (word *)efp->ef_gfp + Wsizeof(*gfp); else firstwd = (word *)efp->ef_gfp + Wsizeof(struct gf_smallmarker); } else firstwd = (word *)efp->ef_efp + Wsizeof(*efp); lastwd = (word *)efp - 3; if (gfp == 0) gfp = efp->ef_gfp; efp = efp->ef_efp; /* * Copy the portion of the stack with endpoints firstwd and lastwd * (inclusive) to the top of the stack. */ rsp -= 2; /* overwrite result */ for (wd = firstwd; wd <= lastwd; wd++) *++rsp = *wd; PushDesc(sval); /* push saved result */ } else { /* * Otherwise, the limit has been reached. Instead of * suspending, remove the current expression frame and * replace the limit counter with the value on top of * the stack (which would have been suspended had the * limit not been reached). */ *lval = *(dptr)(rsp - 1); gfp = efp->ef_gfp; /* * Since an expression frame is being removed, inactive * C generators contained therein are deactivated. */Lsusp_uw: if (efp->ef_ilevel < ilevel) { --ilevel; ExInterp; return A_Lsusp_uw; } rsp = (word *)efp - 1; efp = efp->ef_efp; } break; } case Op_Psusp: { /* suspend from procedure */ /* * An Icon procedure is suspending a value. Determine if the * value being suspended should be dereferenced and if so, * dereference it. If tracing is on, strace is called * to generate a message. Appropriate values are * restored from the procedure frame of the suspending procedure. */ struct descrip tmp; struct descrip sval, *svalp; struct b_proc *sproc; svalp = (dptr)(rsp - 1); sval = *svalp; if (Var(sval)) { word *loc; if (Tvar(sval)) { if (sval.dword == D_Tvsubs) { struct b_tvsubs *tvb; tvb = (struct b_tvsubs *)BlkLoc(sval); loc = (word *)BlkLoc(tvb->ssvar); if (!Tvar(tvb->ssvar)) loc += Offset(tvb->ssvar); } else goto ps_noderef; } else loc = (word *)VarLoc(sval) + Offset(sval); if (InRange(BlkLoc(k_current),loc,rsp)) if (DeRef(*svalp) == Error) { runerr(0, NULL); goto efail; } }ps_noderef: /* * Create the generator frame. */ oldsp = rsp; newgfp = (struct gf_marker *)(rsp + 1); newgfp->gf_gentype = G_Psusp; newgfp->gf_gfp = gfp; newgfp->gf_efp = efp; newgfp->gf_ipc = ipc; newgfp->gf_argp = argp; newgfp->gf_pfp = pfp; gfp = newgfp; rsp += Wsizeof(*gfp); /* * Region extends from first word after the marker for the * generator or expression frame enclosing the call to the * now-suspending procedure to Arg0 of the procedure. */ if (pfp->pf_gfp != 0) { newgfp = (struct gf_marker *)(pfp->pf_gfp); if (newgfp->gf_gentype == G_Psusp) firstwd = (word *)pfp->pf_gfp + Wsizeof(*gfp); else firstwd = (word *)pfp->pf_gfp + Wsizeof(struct gf_smallmarker); } else firstwd = (word *)pfp->pf_efp + Wsizeof(*efp); lastwd = (word *)argp - 1; efp = efp->ef_efp; /* * Copy the portion of the stack with endpoints firstwd and lastwd * (inclusive) to the top of the stack. */ for (wd = firstwd; wd <= lastwd; wd++) *++rsp = *wd; PushVal(oldsp[-1]); PushVal(oldsp[0]); --k_level; if (k_trace) { k_trace--; sproc = (struct b_proc *)BlkLoc(*argp); strace(&(sproc->pname), svalp); } /* * If the scanning environment for this procedure call is in * a saved state, switch environments. */ if (pfp->pf_scan != NULL) { tmp = k_subject; k_subject = *pfp->pf_scan; *pfp->pf_scan = tmp; tmp = *(pfp->pf_scan + 1); IntVal(*(pfp->pf_scan + 1)) = k_pos; k_pos = IntVal(tmp); } efp = pfp->pf_efp; ipc = pfp->pf_ipc; argp = pfp->pf_argp; pfp = pfp->pf_pfp; break; } /* ---Returns--- */ case Op_Eret: { /* return from expression */ /* * Op_Eret removes the current expression frame, leaving the * original top of stack value on top. */ /* * Save current top of stack value in global temporary (no * danger of reentry). */ eret_tmp = *(dptr)&rsp[-1]; gfp = efp->ef_gfp;Eret_uw: /* * Since an expression frame is being removed, inactive * C generators contained therein are deactivated. */ if (efp->ef_ilevel < ilevel) { --ilevel; ExInterp; return A_Eret_uw; } rsp = (word *)efp - 1; efp = efp->ef_efp; PushDesc(eret_tmp); break; } case Op_Pret: { /* return from procedure */ /* * An Icon procedure is returning a value. Determine if the * value being returned should be dereferenced and if so, * dereference it. If tracing is on, rtrace is called to * generate a message. Inactive generators created after * the activation of the procedure are deactivated. Appropriate * values are restored from the procedure frame. */ struct descrip rval; struct b_proc *rproc = (struct b_proc *)BlkLoc(*argp); *argp = *(dptr)(rsp - 1); rval = *argp; if (Var(rval)) { word *loc; if (Tvar(rval)) { if (rval.dword == D_Tvsubs) { struct b_tvsubs *tvb; tvb = (struct b_tvsubs *)BlkLoc(rval); loc = (word *)BlkLoc(tvb->ssvar); if (!Tvar(tvb->ssvar)) loc += Offset(tvb->ssvar); } else goto pr_noderef; } else loc = (word *)VarLoc(rval) + Offset(rval); if (InRange(BlkLoc(k_current),loc,rsp)) if (DeRef(*argp) == Error) { runerr(0, NULL); goto efail; } }pr_noderef: --k_level; if (k_trace) { k_trace--; rtrace(&(rproc->pname), argp); }Pret_uw: if (pfp->pf_ilevel < ilevel) { --ilevel; ExInterp; return A_Pret_uw; } rsp = (word *)argp + 1; efp = pfp->pf_efp; gfp = pfp->pf_gfp; ipc = pfp->pf_ipc; argp = pfp->pf_argp; pfp = pfp->pf_pfp; break; } /* ---Failures--- */ case Op_Efail:efail: /* * Failure has occurred in the current expression frame. */ if (gfp == 0) { /* * There are no suspended generators to resume. * Remove the current expression frame, restoring * values. * * If the failure ipc is 0, propagate failure to the * enclosing frame by branching back to efail. * This happens, for example, in looping control * structures that fail when complete. */ ipc = efp->ef_failure; gfp = efp->ef_gfp; rsp = (word *)efp - 1; efp = efp->ef_efp; if (ipc.op == 0) goto efail; break; } else { /* * There is a generator that can be resumed. Make * the stack adjustments and then switch on the * type of the generator frame marker. */ struct descrip tmp; register struct gf_marker *resgfp = gfp; type = (int)resgfp->gf_gentype; if (type == G_Psusp) { argp = resgfp->gf_argp; if (k_trace) { /* procedure tracing */ k_trace--; ExInterp; atrace(&(((struct b_proc *)BlkLoc(*argp))->pname)); EntInterp; } } ipc = resgfp->gf_ipc; efp = resgfp->gf_efp; gfp = resgfp->gf_gfp; rsp = (word *)resgfp - 1; if (type == G_Psusp) { pfp = resgfp->gf_pfp; /* * If the scanning environment for this procedure call is * supposed to be in a saved state, switch environments. */ if (pfp->pf_scan != NULL) { tmp = k_subject; k_subject = *pfp->pf_scan; *pfp->pf_scan = tmp; tmp = *(pfp->pf_scan + 1); IntVal(*(pfp->pf_scan + 1)) = k_pos; k_pos = IntVal(tmp); } ++k_level; /* adjust procedure level */ } switch (type) { case G_Csusp: { --ilevel; ExInterp; return A_Resumption; break; } case G_Esusp: goto efail; case G_Psusp: break; } break; } case Op_Pfail: /* fail from procedure */ /* * An Icon procedure is failing. Generate tracing message if * tracing is on. Deactivate inactive C generators created * after activation of the procedure. Appropriate values * are restored from the procedure frame. */ --k_level; if (k_trace) { k_trace--; failtrace(&(((struct b_proc *)BlkLoc(*argp))->pname)); }Pfail_uw: if (pfp->pf_ilevel < ilevel) { --ilevel; ExInterp; return A_Pfail_uw; } efp = pfp->pf_efp; gfp = pfp->pf_gfp; ipc = pfp->pf_ipc; argp = pfp->pf_argp; pfp = pfp->pf_pfp; goto efail; /* ---Odds and Ends--- */ case Op_Ccase: /* case clause */ PushNull; PushVal(((word *)efp)[-2]); PushVal(((word *)efp)[-1]); break; case Op_Chfail: /* change failure ipc */ opnd = GetWord; opnd += (word)ipc.opnd; efp->ef_failure.opnd = (word *)opnd; break; case Op_Dup: /* duplicate descriptor */ PushNull; rsp[1] = rsp[-3]; rsp[2] = rsp[-2]; rsp += 2; break; case Op_Field: /* e1.e2 */ PushVal(D_Integer); PushVal(GetWord); Setup_Op(2); signal = Ofield(2,rargp); goto C_rtn_term; case Op_Goto: /* goto */ PutOp(Op_Agoto); opnd = GetWord; opnd += (word)ipc.opnd; PutWord(opnd); ipc.opnd = (word *)opnd; break; case Op_Agoto: /* goto absolute address */ opnd = GetWord; ipc.opnd = (word *)opnd; break; case Op_Init: /* initial */#ifdef WATERLOO_C_V3_0 cw3defect = ipc.op; cw3defect--; ipc.op = cw3defect; *cw3defect = Op_Got /* WATERLOO_C_V3_0 */ *--ipc.op = Op_Goto;#endif /* WATERLOO_C_V3_0 */ opnd = sizeof(*ipc.op) + sizeof(*rsp); opnd += (word)ipc.opnd; ipc.opnd = (word *)opnd; break; case Op_Limit: /* limit */ Setup_Op(0); if (Olimit(0,rargp) == A_Failure) goto efail; else rsp = (word *) rargp + 1; goto mark0;#ifdef TallyOpt case Op_Tally: /* tally */ tallybin[GetWord]++; break;#endif /* TallyOpt */ case Op_Pnull: /* push null descriptor */ PushNull; break; case Op_Pop: /* pop descriptor */ rsp -= 2; break; case Op_Push1: /* push integer 1 */ PushVal(D_Integer); PushVal(1); break; case Op_Pushn1: /* push integer -1 */ PushVal(D_Integer); PushVal(-1); break; case Op_Sdup: /* duplicate descriptor */ rsp += 2; rsp[-1] = rsp[-3]; rsp[0] = rsp[-2]; break; /* ---Co-expressions--- */ case Op_Create: /* create */#ifdef Coexpr PushNull; Setup_Op(0); opnd = GetWord; opnd += (word)ipc.opnd; signal = Ocreate((word *)opnd, rargp); goto C_rtn_term;#else /* Coexpr */ runerr(-401, NULL); goto efail;#endif /* Coexpr */ case Op_Coact: { /* @e */#ifndef Coexpr runerr(-401, NULL); goto efail;#else /* Coexpr */ register struct b_coexpr *ccp, *ncp; dptr dp, tvalp; struct descrip tval; int first; ExInterp; dp = (dptr)(sp - 1);#ifdef TraceBack xargp = dp - 2;#endif /* TraceBack */ if (DeRef(*dp) == Error) { runerr(0, NULL); goto efail; } if (dp->dword != D_Coexpr) { runerr(118, dp); goto efail; } ccp = (struct b_coexpr *)BlkLoc(k_current); ncp = (struct b_coexpr *)BlkLoc(*dp); /* * Dereference the transmited value if needed. */ tval = *(dptr)(sp - 3); if (Var(tval)) { word *loc; if (Tvar(tval)) { if (tval.dword == D_Tvsubs) { struct b_tvsubs *tvb; tvb = (struct b_tvsubs *)BlkLoc(tval); loc = (word *)BlkLoc(tvb->ssvar); if (!Tvar(tvb->ssvar)) loc += Offset(tvb->ssvar); } else goto ca_noderef; } else loc = (word *)VarLoc(tval) + Offset(tval); if (InRange(ccp,loc,sp)) if (DeRef(tval) == Error) { runerr(0, NULL); goto efail; } }ca_noderef: /* * Set activator in new co-expression. */ if (ncp->es_actstk == NULL) { ncp->es_actstk = alcactiv(); if (ncp->es_actstk ==
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:interp
+++++ Continued from previous card +++++
NULL) { runerr(0, NULL); goto efail; } first = 0; } else first = 1; if (pushact(ncp, ccp) == Error) { runerr(0, NULL); goto efail; } if (k_trace) { k_trace--; coacttrace(ccp, ncp); } /* * Save Istate of current co-expression. */ ccp->es_pfp = pfp; ccp->es_argp = argp; ccp->es_efp = efp; ccp->es_gfp = gfp; ccp->es_ipc = ipc; ccp->es_sp = sp; ccp->es_ilevel = ilevel; ccp->tvalloc = (dptr)(sp - 3); /* * Establish Istate for new co-expression. */ pfp = ncp->es_pfp; argp = ncp->es_argp; efp = ncp->es_efp; gfp = ncp->es_gfp; ipc = ncp->es_ipc; sp = ncp->es_sp; ilevel = (int)ncp->es_ilevel; if (tvalp = ncp->tvalloc) { ncp->tvalloc = NULL; *tvalp = tval; } BlkLoc(k_current) = (union block *)ncp; coexp_act = A_Coact; coswitch(ccp->cstate,ncp->cstate,first); EntInterp; if (coexp_act == A_Cofail) goto efail; else rsp -= 2; break;#endif /* Coexpr */ } case Op_Coret: { /* return from co-expression */#ifndef Coexpr runerr(-401, NULL); /* can't happen? */ goto efail;#else /* Coexpr */ register struct b_coexpr *ccp, *ncp; struct descrip rval, *rvalp; ExInterp; ccp = (struct b_coexpr *)BlkLoc(k_current); /* * Dereference the returned value if needed. */ rval = *(dptr)&sp[-1]; if (Var(rval)) { word *loc; if (Tvar(rval)) { if (rval.dword == D_Tvsubs) { struct b_tvsubs *tvb; tvb = (struct b_tvsubs *)BlkLoc(rval); loc = (word *)BlkLoc(tvb->ssvar); if (!Tvar(tvb->ssvar)) loc += Offset(tvb->ssvar); } else goto cr_noderef; } else loc = (word *)VarLoc(rval) + Offset(rval); if (InRange(ccp,loc,sp)) if (DeRef(rval) == Error) { runerr(0, NULL); goto efail; } }cr_noderef: ccp->size++; ncp = popact(ccp); ncp->tvalloc = NULL; rvalp = (dptr)(&ncp->es_sp[-3]); *rvalp = rval; if (k_trace) { k_trace--; corettrace(ccp,ncp); } /* * Save Istate of current co-expression. */ ccp->es_pfp = pfp; ccp->es_argp = argp; ccp->es_efp = efp; ccp->es_gfp = gfp; ccp->es_ipc = ipc; ccp->es_sp = sp; ccp->es_ilevel = ilevel; /* * Establish Istate for new co-expression. */ pfp = ncp->es_pfp; argp = ncp->es_argp; efp = ncp->es_efp; gfp = ncp->es_gfp; ipc = ncp->es_ipc; sp = ncp->es_sp; ilevel = (int)ncp->es_ilevel; BlkLoc(k_current) = (union block *)ncp; coexp_act = A_Coret; coswitch(ccp->cstate, ncp->cstate,1); break;#endif /* Coexpr */ } case Op_Cofail: { /* fail from co-expression */#ifndef Coexpr runerr(-401, NULL); /* can't happen? */ goto efail;#else /* Coexpr */ register struct b_coexpr *ccp, *ncp; ExInterp; ccp = (struct b_coexpr *)BlkLoc(k_current); ncp = popact(ccp); if (k_trace) { k_trace--; cofailtrace(ccp, ncp); } ncp->tvalloc = NULL; /* * Save Istate of current co-expression. */ ccp->es_pfp = pfp; ccp->es_argp = argp; ccp->es_efp = efp; ccp->es_gfp = gfp; ccp->es_ipc = ipc; ccp->es_sp = sp; ccp->es_ilevel = ilevel; /* * Establish Istate for new co-expression. */ pfp = ncp->es_pfp; argp = ncp->es_argp; efp = ncp->es_efp; gfp = ncp->es_gfp; ipc = ncp->es_ipc; sp = ncp->es_sp; ilevel = (int)ncp->es_ilevel; BlkLoc(k_current) = (union block *)ncp; coexp_act = A_Cofail; coswitch(ccp->cstate, ncp->cstate,1); EntInterp; break;#endif /* Coexpr */ } case Op_Quit: /* quit */#ifdef IconCalling ExInterp; /* restores stack pointer for icon_call */ interp_status = A_Pret_uw;#endif /* IconCalling */ goto interp_quit;#ifdef IconCalling case Op_FQuit: /* failing quit */ ExInterp; /* restores stack pointer for icon_call */ interp_status = A_Pfail_uw; goto interp_quit;#endif /* IconCalling */ default: { char buf[50]; sprintf(buf, "unimplemented opcode: %ld (0x%08x)\n", (long)lastop, lastop); syserr(buf); } } continue;C_rtn_term: EntInterp; switch (signal) { case A_Failure: goto efail; case A_Unmark_uw: /* unwind for unmark */ goto Unmark_uw; case A_Lsusp_uw: /* unwind for lsusp */ goto Lsusp_uw; case A_Eret_uw: /* unwind for eret */ goto Eret_uw; case A_Pret_uw: /* unwind for pret */ goto Pret_uw; case A_Pfail_uw: /* unwind for pfail */ goto Pfail_uw; } rsp = (word *)rargp + 1; /* set rsp to result */ continue; }interp_quit: --ilevel;#ifdef MaxLevel fprintf(stderr,"maximum &level = %d\n",maxplevel); fprintf(stderr,"maximum ilevel = %d\n",maxilevel); fprintf(stderr,"maximum sp = %d\n",(long)maxsp - (long)stack); fflush(stderr);#endif /* MaxLevel */#ifdef DumpIcount { int i; for (i = 0; i <= MaxIcode; i++) fprintf(imonc,"\%d\n",icode[i]); fflush(imonc); }#endif /* DumpIcount */#ifndef IconCalling if (ilevel != 0) syserr("interp: termination with inactive generators.");#else if (IDepth == 0 && ilevel != 0) syserr("interp(call in): termination with inactive generators");#endif /* IconCalling */ }#ifdef StackPic/* * The following code is operating-system dependent [@interp.04]. * Diagnostic stack pictures for debugging/monitoring. */#if PORTDeliberate Syntax Error#endif /* PORT */#if AMIGA || ATARI_ST || HIGHC_386 || MACINTOSH || MVS || VM || VMS /* not included */#endif /* AMIGA || ATARI_ST || ... */#if MSDOS || OS2novalue stkdump(op) int op; { word far *stk; word far *i; stk = (word far *)BlkLoc(k_current); stk += Wsizeof(struct b_coexpr); fprintf(stderr,"> stack: %08lx\n", (word)stk); fprintf(stderr,"> sp: %08lx\n", (word)sp); fprintf(stderr,"> pfp: %08lx\n", (word)pfp); fprintf(stderr,"> efp: %08lx\n", (word)efp); fprintf(stderr,"> gfp: %08lx\n", (word)gfp); fprintf(stderr,"> ipc: %08lx\n", (word)ipc.op); fprintf(stderr,"> argp: %08lx\n", (word)argp); fprintf(stderr,"> ilevel: %08lx\n", (word)ilevel); fprintf(stderr,"> op: %d\n", (int)op); for (i = stk; i <= (word far *)sp; i++) fprintf(stderr,"> %08lx\n",(word)*i); fprintf(stderr,"> ----------\n"); fflush(stderr); }#endif /* MSDOS || OS2 */#if UNIX || VMSnovalue stkdump(op) int op; { long *i; fprintf(stderr,"\001stack: %lx\n",(long)(stack + Wsizeof(struct b_coexpr))); fprintf(stderr,"\001pfp: %lx\n",(long)pfp); fprintf(stderr,"\001efp: %lx\n",(long)efp); fprintf(stderr,"\001gfp: %lx\n",(long)gfp); fprintf(stderr,"\001ipc: %lx\n",(long)ipc.op); fprintf(stderr,"\001argp: %lx\n",(long)argp); fprintf(stderr,"\001ilevel: %lx\n",(long)ilevel); fprintf(stderr,"\001op: \%d\n",(int)op); for (i = stack + Wsizeof(struct b_coexpr); i <= sp; i++) fprintf(stderr,"\001%lx\n",*i); fprintf(stderr,"\001----------\n"); fflush(stderr); }#endif /* UNIX || VMS *//* * End of operating-system specific code. */#endif /* StackPic */ :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:invoke.c
/* * Procedure and function invocation. */#include <math.h>#include "::h:config.h"#include "::h:rt.h"#include "rproto.h"#ifdef TraceBackextern dptr xargp;extern word xnargs;#endif /* TraceBack */ /* * invoke -- Perform setup for invocation. */invoke(nargs,cargp,n)dptr *cargp;int nargs, *n;{ register struct pf_marker *newpfp; register dptr newargp; register word *newsp = sp;#ifdef SCO_XENIX register dptr p;#endif /* SCO_XENIX */ register word i; struct b_proc *proc; int nparam; char strbuf[MaxCvtLen]; /* * Point newargp at Arg0 and dereference it. */ newargp = (dptr )(sp - 1) - nargs;#ifdef TraceBack xnargs = nargs; xargp = newargp;#endif /* TraceBack */ if (DeRef(newargp[0]) == Error) { runerr(0, NULL); return I_Fail; } /* * See what course the invocation is to take. */ if (newargp->dword != D_Proc) { /* * Arg0 is not a procedure. */ if (cvint(&newargp[0]) == T_Integer) { /* * Arg0 is an integer, select result. */ i = cvpos(IntVal(newargp[0]), (word)nargs); if (i == CvtFail || i > nargs) return I_Fail;#ifdef SCO_XENIX p = newargp + i; newargp[0] = *p;#else /* SCO_XENIX */ newargp[0] = newargp[i];#endif /* SCO_XENIX */ sp = (word *)newargp + 1; return I_Continue; } else { /* * See if Arg0 can be converted to a string that names a procedure * or operator. If not, generate run-time error 106. */ if (cvstr(&newargp[0],strbuf) == CvtFail || strprc(&newargp[0], (word)nargs) == CvtFail) { runerr(106, newargp); return I_Fail; } } } /* * newargp[0] is now a descriptor suitable for invocation. Dereference * the supplied arguments. */ proc = (struct b_proc *)BlkLoc(newargp[0]); if (proc->nstatic >= 0) /* if negative, don't reference arguments */ for (i = 1; i <= nargs; i++) if (DeRef(newargp[i]) == Error) { runerr(0, NULL); return I_Fail; } /* * Adjust the argument list to conform to what the routine being invoked * expects (proc->nparam). If nparam is less than 0, the number of * arguments is variable. For functions (ndynam = -1) with a * variable number of arguments, nothing need be done. For Icon procedures * with a variable number of arguments, arguments beyond abs(nparam) are * put in a list which becomes the last argument. For fix argument * routines, if too many arguments were supplied, adjusting the stack * pointer is all that is necessary. If too few arguments were supplied, * null descriptors are pushed for each missing argument. */ proc = (struct b_proc *)BlkLoc(newargp[0]); nparam = (int)proc->nparam; if (nparam >= 0) { if (nargs > nparam) newsp -= (nargs - nparam) * 2; else if (nargs < nparam) { i = nparam - nargs; while (i--) { *++newsp = D_Null; *++newsp = 0; } } nargs = nparam;#ifdef TraceBack xnargs = nargs;#endif /* TraceBack */ } else { if (proc->ndynam >= 0) { int lelems; dptr llargp; if (nargs < abs(nparam) - 1) { i = abs(nparam) - 1 - nargs; while (i--) { *++newsp = D_Null; *++newsp = 0; } nargs = abs(nparam) - 1; } lelems = nargs - (abs(nparam) - 1); llargp = &newargp[abs(nparam)]; tended[1] = llargp[-1]; ntended = 1; Ollist(lelems, &llargp[-1]); llargp[0] = llargp[-1]; llargp[-1] = tended[1]; ntended = 0; /* * Reload proc pointer in case Ollist triggered a garbage collection. */ proc = (struct b_proc *)BlkLoc(newargp[0]); newsp = (word *)llargp + 1; nargs = abs(nparam); } } if (proc->ndynam < 0) { /* * A function is being invoked, so nothing else here needs to be done. */ *n = nargs; *cargp = newargp; sp = newsp; if ((nparam == -1) || (proc->ndynam == -2)) return I_Vararg; else return I_Builtin; } /* * Make a stab at catching interpreter stack overflow. This does * nothing for invocation in a co-expression other than &main. */ if (BlkLoc(k_current) == BlkLoc(k_main) && ((char *)sp + PerilDelta) > (char *)stackend) fatalerr(-301, NULL); /* * Build the procedure frame. */ newpfp = (struct pf_marker *)(newsp + 1); newpfp->pf_nargs = nargs; newpfp->pf_argp = argp; newpfp->pf_pfp = pfp; newpfp->pf_ilevel = ilevel; newpfp->pf_scan = NULL; newpfp->pf_ipc = ipc; newpfp->pf_gfp = gfp; newpfp->pf_efp = efp; argp = newargp; pfp = newpfp; newsp += Vwsizeof(*pfp); /* * If tracing is on, use ctrace to generate a message. */ if (k_trace) { k_trace--; ctrace(&(proc->pname), nargs, &newargp[1]); } /* * Point ipc at the icode entry point of the procedure being invoked. */ ipc.opnd = (word *)proc->entryp.icode; efp = 0; gfp = 0; /* * Push a null descriptor on the stack for each dynamic local. */ for (i = proc->ndynam; i > 0; i--) { *++newsp = D_Null; *++newsp = 0; } sp = newsp; k_level++; return I_Continue;} :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:istart.c
/* * Main program if Icon is called as a subprogram. */#include "::h:config.h"#include "::h:rt.h"#include "rproto.h"#ifdef IconCallingnovalue main(argc,argv)int argc;char *argv[]; { int clargc; char **clargv; int i; struct descrip darg; /* * Set up standard Icon interface. This is only necessary so that * Icon can behave normally as if it were the main program. * It is not necessary if Icon is called by a C program for another * purpose. */ icon_setup(argc, argv, &i); while (i--) { /* skip option arguments */ argc--; argv++; } if (!argc) error("no icode file specified"); /* * Read in the icode file argv[1] and initialize the Icon system. * This must be done for any C program calling Icon. */ icon_init(argv[1]); /* * Skip the names of the executable and the file it processes. This * is necessary only to get the right arguments from the command line * to call Icon as if it were the main program and hence provide * the correct values in the list that is the argument of Icon's main * procedure. This is not necessary if Icon is called from C for * another purpose. */ clargv = argv + 2; clargc = argc - 2; /* * Set up a temporary stack and build the necessary list * to call main. */ sp = stack + Wsizeof(struct b_coexpr); PushNull; argp = (dptr)(sp - 1); for (i = 0; i < clargc; i++) { PushAVal(strlen(clargv[i])); PushVal(clargv[i]); } Ollist(clargc, argp); /* * Now that the list is computed, copy its descriptor off the * stack (which is about to be destroyed), reset the argument * pointer, and make the call to the Icon main procedure. */ darg = *argp; argp = 0; icon_call("main", 1, &darg); /* return signal and value ignored */ c_exit(NormalExit); }#else /* IconCalling */static char x; /* avoid empty module */#endif /* IconCalling */ :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:lmisc.c
/* * File: lmisc.c * Contents: create, keywd, limit, llist */#include "::h:config.h"#include "::h:rt.h"#include "rproto.h"#include "::h:keyword.h"#include "::h:version.h"#ifdef PreProcess/* include(../M4/lib.m4) /* *//* */#endif /* PreProcess *//* * create - return an entry block for a co-expression. */OpBlock(create,1,"create",0)Ocreate(entryp, cargp)word *entryp;register dptr cargp; {#ifdef Coexpr register struct b_coexpr *sblkp; register struct b_refresh *rblkp; register dptr dp, ndp, dsp; register word *newsp; int na, nl, i; struct b_proc *cproc; /* * Get a new co-expression stack and initialize. */ if ((sblkp = alccoexp()) == NULL) RunErr(0, NULL); /* * Icon stack starts at word after co-expression stack block. C stack * starts at end of stack region on machines with down-growing C stacks * and somewhere in the middle of the region. * * The C stack is aligned on a doubleword boundary. For upgrowing * stacks, the C stack starts in the middle of the stack portion * of the static block. For downgrowing stacks, the C stack starts * at the end of the static block. */ newsp = (word *)((char *)sblkp + sizeof(struct b_coexpr));#ifdef UpStack sblkp->cstate[0] = ((word)((char *)sblkp + (stksize - sizeof(*sblkp))/2) &~(WordSize*StackAlign-1));#else /* UpStack */ sblkp->cstate[0] = ((word)((char *)sblkp + stksize - WordSize)&~(WordSize*StackAlign-1));#endif /* UpStack */ sblkp->es_argp = (dptr )newsp; /* * Calculate number of arguments and number of local variables. * na is nargs + 1 to include Arg0. */ na = pfp->pf_nargs + 1; cproc = (struct b_proc *)BlkLoc(argp[0]); nl = (int)cproc->ndynam; /* * Get a refresh block for the new co-expression. */ if (blkreq((word)sizeof(struct b_refresh) + (na + nl) * sizeof(struct descrip)) == Error) RunErr(0, NULL); rblkp = alcrefresh(entryp, na, nl); sblkp->freshblk.dword = D_Refresh; BlkLoc(sblkp->freshblk) = (union block *) rblkp; /* * Copy current procedure frame marker into refresh block. */ rblkp->pfmkr = *pfp; rblkp->pfmkr.pf_pfp = 0; /* * Copy arguments into refresh block and onto new stack. */ dp = &argp[0]; ndp = &rblkp->elems[0]; dsp = (dptr)newsp; for (i = 1; i <= na; i++) { *dsp++ = *dp; *ndp++ = *dp++; } /* * Copy procedure frame to new stack and point dsp to word after frame. */ *((struct pf_marker *)dsp) = *pfp; sblkp->es_pfp = (struct pf_marker *)dsp; sblkp->es_pfp->pf_pfp = 0; dsp = (dptr)((word *)dsp + Vwsizeof(*pfp)); sblkp->es_ipc.opnd = entryp; sblkp->es_gfp = 0; sblkp->es_efp = 0; sblkp->es_ilevel = 0; sblkp->tvalloc = NULL; /* * Copy locals to new stack and refresh block. */ dp = &(pfp->pf_locals)[0]; for (i = 1; i <= nl; i++) { *dsp++ = *dp; *ndp++ = *dp++; } /* * Push two null descriptors on the stack. */ *dsp++ = nulldesc; *dsp++ = nulldesc; sblkp->es_sp = (word *)dsp - 1; /* * Return the new co-expression. */ Arg0.dword = D_Coexpr; BlkLoc(Arg0) = (union block *) sblkp; Return;#else /* Coexpr */ RunErr(-401, NULL);#endif /* Coexpr */ } /* * keywd - process keyword. */char *feattab[] = {#if AMIGA "Amiga",#endif /* AMIGA */#if ATARI_ST "Atari ST",#endif /* ATARI_ST */#if HIGHC_386 "MS-DOS/386",#endif /* HIGHC_386 */#if MACINTOSH "Macintosh",#endif /* MACINTOSH */#if MSDOS "MS-DOS",#endif /* MSDOS */#if MVS "MVS",#endif /* MVS */#if OS2 "OS/2",#endif /* OS2 */#if PORT "PORT",#endif /* PORT */#if UNIX "UNIX",#endif /* VM */#if VMS "VMS",#endif /* VMS */#if !EBCDIC "ASCII",#else /* EBCDIC */ "EBCDIC",#endif /* EBCDIC */#ifdef IconCalling "calling to Icon",#endif /* IconCalling */#ifdef Coexpr "co-expressions",#endif /* Coexpr */#ifdef Header "direct execution",#endif /* Header */#ifdef EnvVars "environment variables",#endif /* EnvVars */#ifdef TraceBack "error trace back",#endif /* TraceBack */#ifdef EvalTrace "evaluation tracing",#endif /* EvalTrace */#ifdef ExecImages "executable images",#endif /* ExecImages */#ifndef FixedRegions "expandable regions",#endif /* FixedRegions */#ifdef ExternalFunctions "external functions",#endif /* ExternalFunctions */#ifdef FixedRegions "fixed regions",#endif /* FixedRegions */#ifdef KeyBoardFncs "keyboard functions",#endif /* KeyBoardFncs */#ifdef LargeInts "large integers",#endif /* LargeInts */#ifdef MathFncs "math functions",#endif /* MathFncs */#ifdef MemMon "memory monitoring",#endif /* MEMMON */#ifdef Pipes "pipes",#endif /* Pipes */#ifdef StrInvoke "string invocation",#endif /* StrInvoke */#ifdef SystemFnc "system function",#endif /* SystemFnc */#ifdef DosFncs "MS-DOS extensions",#endif /* DosFncs */ "" };LibDcl(keywd,0,"&keywd") { register int hour; register word i; register char *merid; char **p; char sbuf[MaxCvtLen]; extern word coll_stat, coll_str, coll_blk, coll_tot; long runtim; struct cal_time ct;#if MACINTOSH && MPW/* #pragma unused(nargs) */#endif /* MACINTOSH && MPW */ /* * This is just plug and chug code. For whatever keyword is desired, * the appropriate value is dug out of the system and made into * a suitable Icon value. * * A few special cases are worth noting: * &pos, &random, &trace - built-in trapped variables are returned */ switch ((int)IntVal(Arg0)) { case K_ASCII: Arg0.dword = D_Cset; BlkLoc(Arg0) = (union block *) &k_ascii; break; case K_CLOCK: if (strreq((word)8) == Error) RunErr(0, NULL); getitime(&ct); sprintf(sbuf,"%02d:%02d:%02d", ct.hour, ct.minute, ct.second); StrLen(Arg0) = 8; StrLoc(Arg0) = alcstr(sbuf,(word)8); break; case K_COLLECTIONS: MakeInt(coll_tot, &Arg0); Suspend; MakeInt(coll_stat, &Arg0); Suspend; MakeInt(coll_str, &Arg0); Suspend; MakeInt(coll_blk, &Arg0); Return; case K_CSET: Arg0.dword = D_Cset; BlkLoc(Arg0) = (union block *) &k_cset; break; case K_CURRENT: Arg0 = k_current; break; case K_DATE: if (strreq((word)10) == Error) RunErr(0, NULL); getitime(&ct); sprintf(sbuf, "%04d/%02d/%02d", ct.year, ct.month_no, ct.mday); StrLen(Arg0) = 10; StrLoc(Arg0) = alcstr(sbuf,(word)10); break; case K_DATELINE: getitime(&ct); if ((hour = ct.hour) >= 12) { merid = "pm"; if (hour > 12) hour -= 12; } else { merid = "am"; if (hour < 1) hour += 12; } sprintf(sbuf, "%s, %s %d, %d %d:%02d %s", ct.wday, ct.month_nm, ct.mday, ct.year, hour, ct.minute, merid); if (strreq(i = strlen(sbuf)) == Error) RunErr(0, NULL); StrLen(Arg0) = i; StrLoc(Arg0) = alcstr(sbuf, i); break; case K_DIGITS: Arg0.dword = D_Cset; BlkLoc(Arg0) = (union block *)&k_digits; break; case K_ERROR: Arg0.dword = D_Tvkywd; BlkLoc(Arg0) = (union block *)&tvky_err; break; case K_ERRORNUMBER: if (k_errornumber == 0) Fail; MakeInt((k_errornumber > 0 ? k_errornumber : -k_errornumber), &Arg0); break; case K_ERRORTEXT: if (k_errornumber == 0) Fail; StrLoc(Arg0) = k_errortext; StrLen(Arg0) = strlen(k_errortext); break; case K_ERRORVALUE: if (k_errornumber <= 0) Fail; Arg0 = k_errorvalue; break; case K_ERROUT: Arg0.dword = D_File; BlkLoc(Arg0) = (union block *)&k_errout; break; case K_FEATURES: p = feattab; for(;;) { StrLen(Arg0) = strlen(*p); if (StrLen(Arg0) == 0) Fail; StrLoc(Arg0) = *p; Suspend; p++; } case K_FILE: StrLoc(Arg0) = findfile(ipc.opnd); StrLen(Arg0) = strlen(StrLoc(Arg0)); break; case K_HOST: iconhost(sbuf); if (strreq(i = strlen(sbuf)) == Error) RunErr(0, NULL); StrLen(Arg0) = i; StrLoc(Arg0) = alcstr(sbuf, i); break; case K_INPUT: Arg0.dword = D_File; BlkLoc(Arg0) = (union block *)&k_input; break; case K_LCASE: Arg0.dword = D_Cset; BlkLoc(Arg0) = (union block *)&k_lcase; break; case K_LETTERS: Arg0.dword = D_Cset; BlkLoc(Arg0) = (union block *)&k_letters; break; case K_LEVEL: MakeInt(k_level, &Arg0); break; case K_LINE: MakeInt(findline(ipc.opnd), &Arg0); break; case K Arg0 = k_main; break; case K_OUTPUT: Arg0.dword = D_File; BlkLoc(Arg0) = (union block *)&k_output; break; case K_POS: Arg0.dword = D_Tvkywd; BlkLoc(Arg0) = (union block *) &tvky_pos; break; case K_RANDOM: Arg0.dword = D_Tvkywd; BlkLoc(Arg0) = (union block *) &tvky_ran; break; case K_REGIONS:#ifdef FixedRegions Arg0 = zerodesc;#else /* FixedRegions */ MakeInt(DiffPtrs(statend,statbase) - mstksize, &Arg0);#endif /* FixedRegions */ Suspend; MakeInt(DiffPtrs(strend,strbase), &Arg0); Suspend; MakeInt(DiffPtrs(blkend,blkbase), &Arg0); Return; case K_SOURCE:#ifndef Coexpr Arg(0) = k_main;#else /* Coexpr */ Arg0.dword = D_Coexpr; BlkLoc(Arg0) = (union block *)topact((struct b_coexpr *)BlkLoc(k_current));#endif /* Coexpr */ break; case K_STORAGE:#ifdef FixedRegions Arg0 = zerodesc;#else /* FixedRegions */ MakeInt(DiffPtrs(statfree,statbase) - mstksize, &Arg0);#endif /* FixedRegions */ Suspend; MakeInt(DiffPtrs(strfree,strbase), &Arg0); Suspend; MakeInt(DiffPtrs(blkfree,blkbase), &Arg0); Return; case K_SUBJECT: Arg0.dword = D_Tvkywd; BlkLoc(Arg0) = (union block *) &tvky_sub; break; case K_TIME: runtim = millisec(); MakeInt(runtim, &Arg0); break; case K_TRACE: Arg0.dword = D_Tvkywd; BlkLoc(Arg0) = (union block *)&tvky_trc; break; case K_UCASE: Arg0.dword = D_Cset; BlkLoc(Arg0) = (union block *)&k_ucase; break; case K_VERSION: if (strreq(i = strlen(Version)) == Error) RunErr(0, NULL); StrLen(Arg0) = i; StrLoc(Arg0) = Version; break; default: syserr("keyword: unknown keyword type."); } Return; } /* * limit - explicit limitation initialization. */#ifdef WATERLOO_C_V3_0struct b_iproc Blimit = { T_Proc, Vsizeof(struct b_proc), Olimit, 2, -1, 0, 0, {sizeof(BackSlash)-1,BackSlash}}; Olimit(nargs,cargp,sptr) register dptr cargp;#else /* WATERLOO_C_V3_0 */LibDcl(limit,2,BackSlash)#endif /* WATERLOO_C_V3_0 */ {#if MACINTOSH#if MPW/* #pragma unused(nargs) */#endif /* MPW */#endif /* MACINTOSH */ /* * The limit is both passed and returned in Arg0. The limit must * be an integer. If the limit is 0, the expression being evaluated * fails. If the limit is < 0, it is an error. Note that the * result produced by limit is ultimately picked up by the lsusp * function. */ if (DeRef(Arg0) == Error) RunErr(0, NULL); switch (cvint(&Arg0)) { case T_Integer: break; default: RunErr(101, &Arg0); } if (IntVal(Arg0) < 0) RunErr(205, &Arg0); if (IntVal(Arg0) == 0) Fail; Return; } /* * [ ... ] - create an explicitly specified list. */LibDcl(llist,-1,"[...]") { register word i; register struct b_list *hp; register struct b_lelem *bp; word nslots; nslots = nargs; if (nslots == 0) nslots = MinListSlots; if (blkreq((word)sizeof(struct b_list) + sizeof(struct b_lelem) + nslots * sizeof(struct descrip)) == Error) RunErr(0, NULL); /* * Allocate the list and a list block. */ hp = alclist((word)nargs); bp = alclstb(nslots, (word)0, (word)nargs); /* * Make the list block just allocated into the first and last blocks * for the list. */ hp->listhead = hp->listtail = (union block *)bp; /* * Dereference each argument in turn and assign it to a list element. */ for (i = 1; i <= nargs; i++) { if (DeRef(Arg(i)) == Error) RunErr(0, NULL); bp->lslots[i-1] = Arg(i); } /* * Point Arg0 at the new list and return it. */ ArgType(0) = D_List; Arg(0).vword.bptr = (union block *)hp; Return; } :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:lrec.c
/* * File: lrec.c * Contents: field, mkrec */#include "::h:config.h"#include "::h:rt.h"#include "rproto.h"#ifdef PreProcess/* include(../M4/lib.m4) /* *//* */#endif /* PreProcess *//* * x.y - access field y of record x. */LibDcl(field,2,".") { register word fnum; register struct b_record *rp; register dptr dp; extern word *ftabp, *records;#if MACINTOSH#if MPW/* #pragma unused(nargs) */#endif /* MPW */#endif /* MACINTOSH */ if (DeRef(Arg1) == Error) RunErr(0, NULL); /* * Arg1 must be a record and Arg2 must be a field number. */ if (Arg1.dword != D_Record) RunErr(107, &Arg1); /* * Map the field number into a field number for the record x. */ rp = (struct b_record *) BlkLoc(Arg1); fnum = ftabp[IntVal(Arg2) * *records + rp->recdesc->proc.recnum - 1]; /* * If fnum < 0, x doesn't contain the specified field. */ if (fnum < 0) RunErr(207, &Arg1); /* * Return a pointer to the descriptor for the appropriate field. */ dp = &rp->fields[fnum]; Arg0.dword = D_Var + ((word *)dp - (word *)rp); VarLoc(Arg0) = (dptr)rp; Return; } /* * mkrec - create a record. */LibDcl(mkrec,-1,"mkrec") { register int i; register struct b_proc *bp; register struct b_record *rp; /* * Be sure that call is from a procedure. */ /* * Ensure space for the record to be created. */ if (blkreq((uword)sizeof(struct b_record) + BlkLoc(Arg(0))->proc.nfields*sizeof(struct descrip)) == Error) RunErr(0, NULL); /* * Get a pointer to the record constructor procedure and allocate * a record with the appropriate number of fields. */ bp = (struct b_proc *) BlkLoc(Arg(0)); rp = alcrecd((int)bp->nfields, (union block **)bp); rp->id = (bp->recid)++; /* * Set all fields in the new record to null value. */ for (i = (int)bp->nfields; i > nargs; i--) rp->fields[i-1] = nulldesc; /* * Assign each argument value to a record element and dereference it. */ for ( ; i > 0; i--) { rp->fields[i-1] = Arg(i); if (DeRef(rp->fields[i-1]) == Error) RunErr(0, NULL); } ArgType(0) = D_Record; Arg(0).vword.bptr = (union block *)rp; Return; } :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:lscan.c
/* * File: lscan.c * Contents: bscan, escan */#include "::h:config.h"#include "::h:rt.h"#include "rproto.h"#ifdef PreProcess/* include(../M4/lib.m4) /* *//* */#endif /* PreProcess *//* * bscan - set &subject and &pos upon entry to a scanning expression. * * Arguments are: * Arg0 - new value for &subject * Arg1 - saved value of &subject * Arg2 - saved value of &pos * * A variable pointing to the saved &subject and &pos is returned to be * used by escan. */LibDcl(bscan,2,"?") { char sbuf[MaxCvtLen]; int rc; struct pf_marker *cur_pfp;#if MACINTOSH#if MPW/* #pragma unused(nargs) */#endif /* MPW */#endif /* MACINTOSH */ /* * Convert the new value for &subject to a string. */ if (DeRef(Arg0) == Error) RunErr(0, NULL); switch (cvstr(&Arg0, sbuf)) { case Cvt: /* * The new value for &subject wasn't a string. Allocate the * new value and fall through. */ if (strreq(StrLen(Arg0)) == Error) RunErr(0, NULL); StrLoc(Arg0) = alcstr(StrLoc(Arg0), StrLen(Arg0)); case NoCvt: /* * Establish a new &subject value and set &pos to 1. */ k_subject = Arg0; k_pos = 1; break; default: RunErr(103, &Arg0); } /* If the saved scanning environment belongs to the current procedure * call, put a reference to it in the procedure frame. */ if (pfp->pf_scan == NULL) pfp->pf_scan = &Arg1; cur_pfp = pfp; /* * Suspend with a variable pointing to the saved &subject and &pos. */ ArgType(0) = D_Var; VarLoc(Arg0) = &Arg1; rc = interp(G_Csusp,cargp); if (pfp != cur_pfp) return rc; /* * Leaving scanning environment. Restore the old &subject and &pos values. */ k_subject = Arg1; k_pos = IntVal(Arg2); if (pfp->pf_scan == &Arg1) pfp->pf_scan = NULL; if (rc == A_Resumption) return A_Failure; else return rc; } /* * escan - restore &subject and &pos at the end of a scanning expression. * * Arguments: * Arg0 - variable pointing to old values of &subject and &pos * Arg1 - result of the scanning expression * * The two arguments are reversed, so that the result of the scanning * expression becomes the result of escan. This result is dereferenced * if it refers to &subject or &pos. Then the saved values of &subject * and &pos are exchanged with the current ones. * * Escan suspends once it has restored the old &subject; on failure * the new &subject and &pos are "unrestored", and the failure is * propagated into the using clause. */LibDcl(escan,1,"escan") { struct descrip tmp; int rc; struct pf_marker *cur_pfp;#if MACINTOSH#if MPW/* #pragma unused(nargs) */#endif /* MPW */#endif /* MACINTOSH */ /* * Copy the result of the scanning expression into Arg0, which will * be the result of the scan. */ tmp = Arg0; Arg0 = Arg1; Arg1 = tmp; /* * If the result of the scanning expression is &subject or &pos, * it is dereferenced. */ if (((char *)BlkLoc(Arg0) == (char *)&tvky_sub) || ((char *)BlkLoc(Arg0) == (char *)&tvky_pos)) if (DeRef(Arg0) == Error) RunErr(0, NULL); /* * Swap new and old values of &subject */ tmp = k_subject; k_subject = *VarLoc(Arg1); *VarLoc(Arg1) = tmp; /* * Swap new and old values of &pos */ tmp = *(VarLoc(Arg1) + 1); IntVal(*(VarLoc(Arg1) + 1)) = k_pos; k_pos = IntVal(tmp); /* * If we are returning to the scanning environment of the current * procedure call, indicate that it is no longed in a saved state. */ if (pfp->pf_scan == VarLoc(Arg1)) pfp->pf_scan = NULL; cur_pfp = pfp; /* * Suspend the value of the scanning expression. */ rc = interp(G_Csusp,cargp); if (pfp != cur_pfp) return rc; /* * Re-entering scanning environment, exchange the values of &subject * and &pos again */ tmp = k_subject; k_subject = *VarLoc(Arg1); *VarLoc(Arg1) = tmp; tmp = *(VarLoc(Arg1) + 1); IntVal(*(VarLoc(Arg1) +1)) = k_pos; k_pos = IntVal(tmp); if (pfp->pf_scan == NULL) pfp->pf_scan = VarLoc(Arg1); if (rc == A_Resumption) return A_Failure; else return rc; } :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:Makefile
/* * File: oarith.c * Contents: divide, minus, mod, mult, neg, number, plus, powr */#include <math.h>#include "::h:config.h"#include "::h:rt.h"#include "rproto.h"#ifdef PreProcess/* include(../M4/ops.m4) /* *//* */#endif /* PreProcess */#ifdef SUN#include <signal.h>#endif /* SUN */int over_flow; /* * x / y - divide y into x. */OpDcl(divide,2,"/") { register int t1, t2; double r1, r2; /* * Arg1 and Arg2 must be numeric. */ if ((t1 = cvnum(&Arg1)) == CvtFail) RunErr(102, &Arg1); if ((t2 = cvnum(&Arg2)) == CvtFail) RunErr(102, &Arg2); if (t1 == T_Integer && t2 == T_Integer) { /* * Arg1 and Arg2 are both integers, just divide them and return the * result. */ if (IntVal(Arg2) == 0L) RunErr(201, &Arg2);#if MSDOS && LATTICE { long i, j; i = IntVal(Arg1); j = i / IntVal(Arg2); MakeInt(j, &Arg0); }#else /* MSDOS && LATTICE */ MakeInt(IntVal(Arg1) / IntVal(Arg2), &Arg0);#endif /* MSDOS && LATTICE */ } else if (t1 == T_Real || t2 == T_Real) { /* * Either Arg1 or Arg2 or both is real, convert the real values to * integers, divide them, and return the result. */ if (t1 != T_Real) {#ifdef LargeInts if (t1 == T_Bignum) r1 = bigtoreal(&Arg1); else#endif /* LargeInts */#ifdef WATERLOO_C_V3_0 { long int l; double d; d = IntVal(Arg1); r1 = d; }#else /* WATERLOO_C_V3_0 */ r1 = IntVal(Arg1);#endif /* WATERLOO_C_V3_0 */ } else r1 = BlkLoc(Arg1)->realblk.realval; if (t2 != T_Real) {#ifdef LargeInts if (t2 == T_Bignum) r2 = bigtoreal(&Arg2); else#endif /* LargeInts */#ifdef WATERLOO_C_V3_0 { long int l; double d; d = IntVal(Arg2); r2 = d; }#else /* WATERLOO_C_V3_0 */ r2 = IntVal(Arg2);#endif /* WATERLOO_C_V3_0 */ } else r2 = BlkLoc(Arg2)->realblk.realval; if (r2 == 0.0) RunErr(-204, NULL); if (makereal(r1 / r2, &Arg0) == Error) RunErr(0, NULL);#ifdef SUN if (((struct b_real *)BlkLoc(Arg0))->realval == HUGE) kill(getpid(),SIGFPE);#endif /* SUN */ }#ifdef LargeInts else { /* * Neither Arg1 or Arg2 are real and at least one is a large int. */ if (bigdiv(&Arg1, &Arg2, &Arg0) == Error) /* alcbignum failed */ RunErr(0, NULL); }#endif /* LargeInts */ Return; } /* * x - y - subtract y from x. */OpDcl(minus,2,"-") { register int t1, t2; double r1, r2; /* * x and y must be numeric. Save the cvnum return values for later use. */ if ((t1 = cvnum(&Arg1)) == CvtFail) RunErr(102, &Arg1); if ((t2 = cvnum(&Arg2)) == CvtFail) RunErr(102, &Arg2); if (t1 == T_Integer && t2 == T_Integer) { /* * Both x and y are integers. Perform integer subtraction and place * the result in Arg0 as the return value. */ MakeInt(sub(IntVal(Arg1), IntVal(Arg2)), &Arg0); if (over_flow)#ifdef LargeInts if (bigsub(&Arg1, &Arg2, &Arg0) == Error) /* alcbignum failed */ RunErr(0, NULL);#else /* LargeInts */ RunErr(-203, NULL);#endif /* LargeInts */ } else if (t1 == T_Real || t2 == T_Real) { /* * Either x or y is real, convert the other to a real, perform * the subtraction and place the result in Arg0 as the return value. */ if (t1 != T_Real) {#ifdef LargeInts if (t1 == T_Bignum) r1 = bigtoreal(&Arg1); else#endif /* LargeInts */#ifdef WATERLOO_C_V3_0 { long int l; double d; d = IntVal(Arg1); r1 = d; }#else /* WATERLOO_C_V3_0 */ r1 = IntVal(Arg1);#endif /* WATERLOO_C_V3_0 */ } else r1 = BlkLoc(Arg1)->realblk.realval; if (t2 != T_Real) {#ifdef LargeInts if (t2 == T_Bignum) r2 = bigtoreal(&Arg2); else#endif /* LargeInts */#ifdef WATERLOO_C_V3_0 { long int l; double d; d = IntVal(Arg2); r2 = d; }#else /* WATERLOO_C_V3_0 */ r2 = IntVal(Arg2);#endif /* WATERLOO_C_V3_0 */ } else r2 = BlkLoc(Arg2)->realblk.realval;#ifdef RTACIS { double rtbug_temporary; /* bug with "-" arithmetic as parameter */ rtbug_temporary = r1 - r2; if (makereal(rtbug_temporary, &Arg0) == Error) RunErr(0, NULL);#else /* RTACIS */ if (makereal(r1 - r2, &Arg0) == Error) RunErr(0, NULL);#endif /* RTACIS */ }#ifdef LargeInts else { /* * Neither Arg1 or Arg2 are real and at least one is a large int. */ if (bigsub(&Arg1, &Arg2, &Arg0) == Error) /* alcbignum failed */ RunErr(0, NULL); }#endif /* LargeInts */ Return; } /* * x % y - take remainder of x / y. */OpDcl(mod,2,"%") { register int t1, t2; long int_rslt; double r1, r2, real_rslt; /* * x and y must be numeric. Save the cvnum return values for later use. */ if ((t1 = cvnum(&Arg1)) == CvtFail) RunErr(102, &Arg1); if ((t2 = cvnum(&Arg2)) == CvtFail) RunErr(102, &Arg2); if (t1 == T_Integer && t2 == T_Integer) { /* * Both x and y are integers. If y is 0, generate an error because * it's divide by 0. Otherwise, just return the modulus of the * two arguments. */ if (IntVal(Arg2) == 0L) RunErr(202, &Arg2);#if MSDOS && LATTICE { long i; i = IntVal(Arg1); int_rslt = i % IntVal(Arg2); }#else /* MSDOS && LATTICE */ int_rslt = IntVal(Arg1) % IntVal(Arg2);#endif /* MSDOS && LATTICE */ /* * The sign of the result must match that of n1. */ if (IntVal(Arg1) < 0) { if (int_rslt > 0) int_rslt -= Abs(IntVal(Arg2)); } else if (int_rslt < 0) int_rslt += Abs(IntVal(Arg2)); MakeInt(int_rslt, &Arg0); } else if (t1 == T_Real || t2 == T_Real) { /* * Either x or y is real, convert the other to a real, get * the modulus, convert the result to an integer and place it * in Arg0 as the return value. */ if (t1 != T_Real) {#ifdef LargeInts if (t1 == T_Bignum) r1 = bigtoreal(&Arg1); else#endif /* LargeInts */#ifdef WATERLOO_C_V3_0 { long int l; double d; d = IntVal(Arg1); r1 = d; }#else /* WATERLOO_C_V3_0 */ r1 = IntVal(Arg1);#endif /* WATERLOO_C_V3_0 */ } else r1 = BlkLoc(Arg1)->realblk.realval; if (t2 != T_Real) {#ifdef LargeInts if (t2 == T_Bignum) r2 = bigtoreal(&Arg2); else#endif /* LargeInts */#ifdef WATERLOO_C_V3_0 { long int l; double d; d = IntVal(Arg2); r2 = d; }#else /* WATERLOO_C_V3_0 */ r2 = IntVal(Arg2);#endif /* WATERLOO_C_V3_0 */ } else r2 = BlkLoc(Arg2)->realblk.realval; real_rslt = r1 - r2 * (int)(r1 / r2); /* * The sign of the result must match that of n1. */ if (r1 < 0.0) { if (real_rslt > 0.0) real_rslt -= fabs(r2); } else if (real_rslt < 0.0) real_rslt += fabs(r2); if (makereal(real_rslt, &Arg0) == Error) RunErr(0, NULL); }#ifdef LargeInts else { /* * Neither Arg1 or Arg2 are real and at least one is a large int. */ if (bigmod(&Arg1, &Arg2, &Arg0) == Error) /* alcbignum failed */ RunErr(0, NULL); }#endif /* LargeInts */ Return; } /* * x * y - multiply x and y. */OpDcl(mult,2,"*") { register int t1, t2; double r1, r2; /* * Arg1 and Arg2 must be numeric. Save the cvnum return values for later * use. */ if ((t1 = cvnum(&Arg1)) == CvtFail) RunErr(102, &Arg1); if ((t2 = cvnum(&Arg2)) == CvtFail) RunErr(102, &Arg2); if (t1 == T_Integer && t2 == T_Integer) { /* * Both Arg1 and Arg2 are integers. Perform the multiplication and * and place the result in Arg0 as the return value. */ MakeInt(mul(IntVal(Arg1), IntVal(Arg2)), &Arg0); if (over_flow)#ifdef LargeInts if (bigmul(&Arg1, &Arg2, &Arg0) == Error) /* alcbignum failed */ RunErr(0, NULL);#else /* LargeInts */ RunErr(-203, NULL);#endif /* LargeInts */ } else i T_Real || t2 == T_Real) { /* * Either Arg1 or Arg2 is real, convert the other to a real, perform * the subtraction and place the result in Arg0 as the return value. */ if (t1 != T_Real) {#ifdef LargeInts if (t1 == T_Bignum) r1 = bigtoreal(&Arg1); else#endif /* LargeInts */#ifdef WATERLOO_C_V3_0 { long int l; double d; d = IntVal(Arg1); r1 = d; }#else /* WATERLOO_C_V3_0 */ r1 = IntVal(Arg1);#endif /* WATERLOO_C_V3_0 */ } else r1 = BlkLoc(Arg1)->realblk.realval; if (t2 != T_Real) {#ifdef LargeInts if (t2 == T_Bignum) r2 = bigtoreal(&Arg2); else#endif /* LargeInts */#ifdef WATERLOO_C_V3_0 { long int l; double d; d = IntVal(Arg2); r2 = d; }#else /* WATERLOO_C_V3_0 */ r2 = IntVal(Arg2);#endif /* WATERLOO_C_V3_0 */ } else r2 = BlkLoc(Arg2)->realblk.realval; if (makereal(r1 * r2, &Arg0) == Error) RunErr(0, NULL); }#ifdef LargeInts else { /* * Neither Arg1 or Arg2 are real and at least one is a large int. */ if (bigmul(&Arg1, &Arg2, &Arg0) == Error) /* alcbignum failed */ RunErr(0, NULL); }#endif /* LargeInts */ Return; } /* * -x - negate x. */OpDcl(neg,1,"-") { /* * Arg1 must be numeric. */ switch (cvnum(&Arg1)) { case T_Integer: /* * If Arg1 is an integer, check for overflow by negating it and * seeing if the negation didn't "work". Use MakeInt to * construct the return value. */ MakeInt(neg(IntVal(Arg1)), &Arg0); if (over_flow)#ifdef LargeInts if (bigneg(&Arg1, &Arg0) == Error) /* alcbignum failed */ RunErr(0, NULL);#else /* LargeInts */ RunErr(-203, &Arg1);#endif /* LargeInts */ break;#ifdef LargeInts case T_Bignum: if (cpbignum(&Arg1, &Arg0) == Error) /* alcbignum failed */ RunErr(0, NULL); BlkLoc(Arg0)->bignumblk.sign ^= 1; break;#endif /* LargeInts */ case T_Real: /* * Arg1 is real, just negate it and use makereal to construct the * return value. */#ifdef RTACIS { double rtbug_temporary; /* bug with "-" as parameter */ rtbug_temporary = -BlkLoc(Arg1)->realblk.realval; if (makereal(rtbug_temporary, &Arg0) == Error) RunErr(0, NULL); }#else /* RTACIS */ if (makereal(-BlkLoc(Arg1)->realblk.realval, &Arg0) == Error) RunErr(0, NULL);#endif /* RTACIS */ break; default: /* * Arg1 is not numeric. */ RunErr(102, &Arg1); } Return; } /* * +x - convert x to numeric type. * Operational definition: generate runerr if x is not numeric. */OpDcl(number,1,"+") { switch (cvnum(&Arg1)) { case T_Integer:#ifdef LargeInts case T_Bignum:#endif /* LargeInts */ case T_Real: Arg0 = Arg1; break; default: RunErr(102, &Arg1); } Return; } /* * x + y - add x and y. */OpDcl(plus,2,"+") { register int t1, t2; double r1, r2; /* * Arg1 and Arg2 must be numeric. Save the cvnum return values for later * use. */ if ((t1 = cvnum(&Arg1)) == CvtFail) RunErr(102, &Arg1); if ((t2 = cvnum(&Arg2)) == CvtFail) RunErr(102, &Arg2); if (t1 == T_Integer && t2 == T_Integer) { /* * Both Arg1 and Arg2 are integers. Perform integer addition and plcae * the result in Arg0 as the return value. */ MakeInt(add(IntVal(Arg1), IntVal(Arg2)), &Arg0); if (over_flow)#ifdef LargeInts if (bigadd(&Arg1, &Arg2, &Arg0) == Error) /* alcbignum failed */ RunErr(0, NULL);#else /* LargeInts */ RunErr(-203, NULL);#endif /* LargeInts */ } else if (t1 == T_Real || t2 == T_Real) { /* * Either Arg1 or Arg2 is real, convert the other to a real, perform * the addition and place the result in Arg0 as the return value. */ if (t1 != T_Real) {#ifdef LargeInts if (t1 == T_Bignum) r1 = bigtoreal(&Arg1); else#endif /* LargeInts */#ifdef WATERLOO_C_V3_0 { long int l; double d; d = IntVal(Arg1); r1 = d; }#else /* WATERLOO_C_V3_0 */ r1 = IntVal(Arg1);#endif /* WATERLOO_C_V3_0 */ } else r1 = BlkLoc(Arg1)->realblk.realval; if (t2 != T_Real) {#ifdef LargeInts if (t2 == T_Bignum) r2 = bigtoreal(&Arg2); else#endif /* LargeInts */#ifdef WATERLOO_C_V3_0 { long int l; double d; d = IntVal(Arg2); r2 = d; }#else /* WATERLOO_C_V3_0 */ r2 = IntVal(Arg2);#endif /* WATERLOO_C_V3_0 */ } else r2 = BlkLoc(Arg2)->realblk.realval; if (makereal(r1 + r2, &Arg0) == Error) RunErr(0, NULL); }#ifdef LargeInts else { /* * Neither Arg1 or Arg2 are real and at least one is a large int. */ if (bigadd(&Arg1, &Arg2, &Arg0) == Error) /* alcbignum failed */ RunErr(0, NULL); }#endif /* LargeInts */ Return; } /* * x ^ y - raise x to the y power. */#if AMIGA#if AZTEC_C#ifndef RTACIS#define RTACIS#define AZTECHACK#endif /* RTACIS */#endif /* AZTEC_C */#endif /* AMIGA */OpDcl(powr,2,"^") { register int t1, t2; double r1, r2; /* * Arg1 and Arg2 must be numeric. Save the cvnum return values for later * use. */ if ((t1 = cvnum(&Arg1)) == CvtFail) RunErr(102, &Arg1); if ((t2 = cvnum(&Arg2)) == CvtFail) RunErr(102, &Arg2); if (t1 == T_Integer && t2 == T_Integer) { /* * Both Arg1 and Arg2 are integers. Perform integer exponentiation * and place the result in Arg0 as the return value. */#ifdef LargeInts if (bigpow(&Arg1, &Arg2, &Arg0) == Error) /* alcbignum failed */ RunErr(0, NULL);#else /* LargeInts */ MakeInt(ipow(IntVal(Arg1), IntVal(Arg2)), &Arg0); if (over_flow) RunErr(-203, NULL);#endif /* LargeInts */ } else if (t1 == T_Real || t2 == T_Real) { /* * Either x or y is real, convert the other to a real, perform * real exponentiation and place the result in Arg0 as the * return value. */ if (t1 != T_Real) {#ifdef LargeInts if (t1 == T_Bignum) r1 = bigtoreal(&Arg1); else#endif /* LargeInts */#ifdef WATERLOO_C_V3_0 { long int l; double d; d = IntVal(Arg1); r1 = d; }#else /* WATERLOO_C_V3_0 */ r1 = IntVal(Arg1);#endif /* WATERLOO_C_V3_0 */ } else r1 = BlkLoc(Arg1)->realblk
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:oarith
+++++ Continued from previous card +++++
.realval; if (t2 != T_Real) {#ifdef LargeInts if (t2 == T_Bignum) r2 = bigtoreal(&Arg2); else#endif /* LargeInts */#ifdef WATERLOO_C_V3_0 { long int l; double d; d = IntVal(Arg2); r2 = d; }#else /* WATERLOO_C_V3_0 */ r2 = IntVal(Arg2);#endif /* WATERLOO_C_V3_0 */ } else r2 = BlkLoc(Arg2)->realblk.realval; if (r1 == 0.0 && r2 <= 0.0) /* * Tried to raise zero to a negative power. */ RunErr(-204, NULL); if (r1 < 0.0 && t2 == T_Real) /* * Tried to raise a negative number to a real power. */ RunErr(-206, NULL);#ifdef RTACIS { double rtbug_temporary; /* bug in pow routine for negative x */ if ((r1 < 0.0) && /* integral? */ (((double)((long int)r2)) == rs)) { rtbug_temporary = -r1; /* * The following is correct only if the eis odd. * If the exponent is even, it should be * * pow(-rtbug_temporary,r2); * */ rtbug_temporary = -pow(rtbug_temporary, r2); } else rtbug_temporary = pow(r1, r2); if (makereal(rtbug_temporary, &Arg0) == Error) RunErr(0, NULL); }#else /* RTACIS */ if (makereal(pow(r1, r2), &Arg0) == Error) RunErr(0, NULL);#endif /* RTACIS */ }#ifdef LargeInts else { /* * Neither Arg1 or Arg2 are real and at least one is a large int. */ if (bigpow(&Arg1, &Arg2, &Arg0) == Error) /* alcbignum failed */ RunErr(0, NULL); }#endif /* LargeInts */ Return; }#if AMIGA#if AZTEC_C#ifdef AZTECHACK#undef RTACIS#endif /* AZTECHACK */#endif /* AZTEC_C */#endif /* AMIGA */ #ifndef LargeIntslong ipow(n1, n2)long n1, n2; { long result; if (n1 == 0 && n2 <= 0) { over_flow = 1; return 0; } if (n2 < 0) return 0; result = 1L; while (n2 > 0) { if (n2 & 01L) result *= n1; n1 *= n1; n2 >>= 1; } over_flow = 0; return result; }#endif /* LargeInts */ :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:oasgn.c
/* * File: oasgn.c * Contents: asgn, rasgn, rswap, swap */#include "::h:config.h"#include "::h:rt.h"#include "rproto.h"#ifdef PreProcess/* include(../M4/ops.m4) /* *//* */#endif /* PreProcess *//* * x := y - assign y to x. */OpDcl(asgn,2,":=") { /* * Make sure that Arg1 is a variable. */ if (!Var(Arg1)) RunErr(111, &Arg1); /* * The returned result is the variable to which assignment is being * made. */ Arg0 = Arg1; /* * All the work is done by doasgn. Note that Arg1 is known * to be a variable. */ switch (doasgn(&Arg1, &Arg2)) { case Success: Return; case Failure: Fail; case Error: RunErr(0, NULL); } } /* * x <- y - assign y to x. * Reverses assignment if resumed. */OpDcl(rasgn,2,"<-") { /* * Arg1 must be a variable. */ if (!Var(Arg1)) RunErr(111, &Arg1); /* * The return value is the variable Arg1, so make a copy of it before * it is dereferenced. */ Arg0 = Arg1; if (DeRef(Arg1) == Error) RunErr(0, NULL); /* * Assign Arg2 to Arg1 and suspend. */ switch (doasgn(&Arg0, &Arg2)) { case Success: Suspend; break; case Failure: Fail; case Error: RunErr(0, NULL); } /* * Reverse the assignment by assigning the old value * of back and fail. */ if (doasgn(&Arg0, &Arg1) == Error) RunErr(0, NULL); Fail; } /* * x <-> y - swap values of x and y. * Reverses swap if resumed. */OpDcl(rswap,2,"<->") { register union block *bp1, *bp2; word adj1, adj2; /* * Arg1 and Arg2 must be variables. */ if (!Var(Arg1)) { RunErr(111, &Arg1); } if (!Var(Arg2)) { RunErr(111, &Arg2); } /* * Make copies of Arg1 and Arg2 as variables in Arg0 and Arg3. */ Arg0 = Arg1; Arg3 = Arg2; adj1 = adj2 = 0; if (Arg1.dword == D_Tvsubs && Arg2.dword == D_Tvsubs) { bp1 = BlkLoc(Arg1); bp2 = BlkLoc(Arg2); if (VarLoc(bp1->tvsubs.ssvar) == VarLoc(bp2->tvsubs.ssvar) && Offset(bp1->tvsubs.ssvar) == Offset(bp2->tvsubs.ssvar)) { /* * Arg1 and Arg2 are both substrings of the same string; set * adj1 and adj2 for use in locating the substrings after * an assignment has been made. If Arg1 is to the right of Arg2, * set adj1 := *Arg1 - *Arg2, otherwise if Arg2 is to the right of * Arg1, set adj2 := *Arg2 - *Arg1. Note that the adjustment values * may be negative. */ if (bp1->tvsubs.sspos > bp2->tvsubs.sspos) adj1 = bp1->tvsubs.sslen - bp2->tvsubs.sslen; else if (bp2->tvsubs.sspos > bp1->tvsubs.sspos) adj2 = bp2->tvsubs.sslen - bp1->tvsubs.sslen; } } if (DeRef(Arg1) == Error) { RunErr(0, NULL); } if (DeRef(Arg2) == Error) { RunErr(0, NULL); } /* * Do Arg1 := Arg2 */ switch (doasgn(&Arg0, &Arg2)) { case Success: break; case Failure: Fail; case Error: RunErr(0, NULL); } if (adj2 != 0) /* * Arg2 is to the right of Arg1 and the assignment Arg := Arg2 has * shifted the position of Arg2. Add adj2 to the position of Arg2 * to account for the replacement of Arg1 by Arg2. */ BlkLoc(Arg3)->tvsubs.sspos += adj2; /* * Do Arg2 := Arg1 */ switch (doasgn(&Arg3, &Arg1)) { case Success: break; case Failure: Fail; case Error: RunErr(0, NULL); } if (adj1 != 0) /* * Arg1 is to the right of Arg2 and the assignment Arg2 := Arg1 has * shifted the position of Arg1. Add adj2 to the position of Arg1 * to account for the replacement of Arg2 by Arg1. */ BlkLoc(Arg0)->tvsubs.sspos += adj1; /* * Suspend Arg1 with the assignment in effect. */ Suspend; /* * If resumed, the assignments are undone. Note that the string position * adjustments are opposite those done earlier. */ switch (doasgn(&Arg0, &Arg1)) { /* restore Arg1 */ case Success: break; case Failure: Fail; case Error: RunErr(0, NULL); } if (adj2 != 0) BlkLoc(Arg3)->tvsubs.sspos -= adj2; switch (doasgn(&Arg3, &Arg2)) { /* restore Arg2 */ case Success: break; case Failure: Fail; case Error: RunErr(0, NULL); } if (adj1 != 0) BlkLoc(Arg0)->tvsubs.sspos -= adj1; Fail; } /* * x :=: y - swap values of x and y. */OpDcl(swap,2,":=:") { register union block *bp1, *bp2; word adj1, adj2; /* * Arg1 and Arg2 must be variables. */ if (!Var(Arg1)) { RunErr(111, &Arg1); } if (!Var(Arg2)) { RunErr(111, &Arg2); } /* * Make copies of Arg1 and Arg2 as variables in Arg0 and Arg3. */ Arg0 = Arg1; Arg3 = Arg2; adj1 = adj2 = 0; if (Arg1.dword == D_Tvsubs && Arg2.dword == D_Tvsubs) { bp1 = BlkLoc(Arg1); bp2 = BlkLoc(Arg2); if (VarLoc(bp1->tvsubs.ssvar) == VarLoc(bp2->tvsubs.ssvar) && Offset(bp1->tvsubs.ssvar) == Offset(bp2->tvsubs.ssvar)) { /* * Arg1 and Arg2 are both substrings of the same string, set * adj1 and adj2 for use in locating the substrings after * an assignment has been made. If Arg1 is to the right of Arg2, * set adj1 := *Arg1 - *Arg2, otherwise if Arg2 is to the right of * Arg1, set adj2 := *Arg2 - *Arg1. Note that the adjustment * values may be negative. */ if (bp1->tvsubs.sspos > bp2->tvsubs.sspos) adj1 = bp1->tvsubs.sslen - bp2->tvsubs.sslen; else if (bp2->tvsubs.sspos > bp1->tvsubs.sspos) adj2 = bp2->tvsubs.sslen - bp1->tvsubs.sslen; } } if (DeRef(Arg1) == Error) { RunErr(0, NULL); } if (DeRef(Arg2) == Error) { RunErr(0, NULL); } /* * Do Arg1 := Arg2 */ switch (doasgn(&Arg0, &Arg2)) { case Success: break; case Failure: Fail; case Error: RunErr(0, NULL); } if (adj2 != 0) /* * Arg2 is to the right of Arg1 and the assignment Arg1 := Arg2 has * shifted the position of Arg2. Add adj2 to the position of Arg2 * to account for the replacement of Arg1 by Arg2. */ BlkLoc(Arg3)->tvsubs.sspos += adj2; /* * Do Arg2 := Arg1 */ switch (doasgn(&Arg3, &Arg1)) { case Success: break; case Failure: Fail; case Error: RunErr(0, NULL); } if (adj1 != 0) /* * Arg1 is to the right of Arg2 and the assignment Arg2 := Arg1 has * shifted the position of Arg1. Add adj2 to the position of Arg1 to * account for the replacement of Arg2 by Arg1. */ BlkLoc(Arg0)->tvsubs.sspos += adj1; Return; } :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:ocat.c
/* * File: ocat.c * Contents: cat, lconcat */#include "::h:config.h"#include "::h:rt.h"#include "rproto.h"#ifdef PreProcess/* include(../M4/ops.m4) /* *//* */#endif /* PreProcess *//* * x || y - concatenate strings x and y. */OpDcl(cater,2,"||") { char sbuf1[MaxCvtLen]; /* buffers for conversion to string */ char sbuf2[MaxCvtLen]; /* * Convert arguments to strings if necessary. */ if (cvstr(&Arg1, sbuf1) == CvtFail) RunErr(103, &Arg1); if (cvstr(&Arg2, sbuf2) == CvtFail) RunErr(103, &Arg2); if (StrLoc(Arg1) + StrLen(Arg1) == strfree) { /* * The end of Arg1 is at the end of the string space. Hence, * Arg1 was the last string allocated. Arg1 is not copied. * Instead, Arg2 is appended to the string space and the * result is pointed to the start of Arg1. * Space is only needed for the string being appended */ if (strreq(StrLen(Arg2)) == Error) RunErr(0, NULL); StrLoc(Arg0) = StrLoc(Arg1); } else { /* * Ensure space for the resulting concatenated string */ if (strreq(StrLen(Arg1) + StrLen(Arg2)) == Error) RunErr(0, NULL); /* * Otherwise, append Arg1 to the end of the string space and * point the result to the start of Arg1. */ StrLoc(Arg0) = alcstr(StrLoc(Arg1),StrLen(Arg1)); } /* * Append Arg2 to the end of the string space. */ alcstr(StrLoc(Arg2),StrLen(Arg2)); /* * Set the length of the result and return. */ StrLen(Arg0) = StrLen(Arg1) + StrLen(Arg2); Return; } /* * x ||| y - concatenate lists x and y. */OpDcl(lconcat,2,"|||") { register struct b_list *bp1, *bp2; register struct b_lelem *lp1, *lp2; word size1, size2; /* * x and y must be lists. */ if (Arg1.dword != D_List) RunErr(108, &Arg1); if (Arg2.dword != D_List) RunErr(108, &Arg2); /* * Get the size of both lists. */ size1 = BlkLoc(Arg1)->list.size; size2 = BlkLoc(Arg2)->list.size; /* * Make a copy of both lists. */ if (cplist(&Arg1, &Arg1, (word)1, size1 + 1) == Error) RunErr(0, NULL); if (cplist(&Arg2, &Arg2, (word)1, size2 + 1) == Error) RunErr(0, NULL); /* * Get a pointer to both lists. bp1 points to the copy of Arg1 and is * the list that will be returned. */ bp1 = (struct b_list *) BlkLoc(Arg1); bp2 = (struct b_list *) BlkLoc(Arg2); /* * Perform the concatenation by hooking the lists together. */ lp1 = (struct b_lelem *) bp1->listtail; lp2 = (struct b_lelem *) bp2->listhead; lp1->listnext = (union block *) lp2; lp2->listprev = (union block *) lp1; /* * Adjust the size field to reflect the length of the concatenated lists. */ bp1->size = size1 + size2; bp1->listtail = bp2->listtail; Arg0 = Arg1; Return; } :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:ocomp.c
/* * File: ocomp.c * Contents: lexeq, lexge, lexgt, lexle, lexlt, lexne, numeq, numge, * numgt, numle, numlt, numne, eqv, neqv */#include "::h:config.h"#include "::h:rt.h"#include "rproto.h"#ifdef PreProcess/* include(../M4/ops.m4) /* *//* */#endif /* PreProcess *//* * x == y - test if x is lexically equal to y. */OpDcl(lexeq,2,"==") { register int t; char sbuf1[MaxCvtLen], sbuf2[MaxCvtLen]; /* * Arg1 and Arg2 must be strings. Save the cvstr return value for Arg2 * because Arg2 is the result (if any). */ if (cvstr(&Arg1, sbuf1) == CvtFail) RunErr(103, &Arg1); if ((t = cvstr(&Arg2, sbuf2)) == CvtFail) RunErr(103, &Arg2); /* * If the strings have different lengths they cannot be equal. */ if (StrLen(Arg1) != StrLen(Arg2)) Fail; /* * lexcmp does the work. */ if (lexcmp(&Arg1, &Arg2) != Equal) Fail; /* * Return Arg2 as the result of the comparison. If Arg2 was converted to * a string, a copy of it is allocated. */ Arg0 = Arg2; if (t == Cvt) { if (strreq(StrLen(Arg0)) == Error) RunErr(0, NULL); StrLoc(Arg0) = alcstr(StrLoc(Arg0), StrLen(Arg0)); } Return; } /* * x >>= y - test if x is lexically greater than or equal to y. */OpDcl(lexge,2,">>=") { register int t; char sbuf1[MaxCvtLen], sbuf2[MaxCvtLen]; /* * Arg1 and Arg2 must be strings. Save the cvstr return value for Arg2 * because Arg2 is the result (if any). */ if (cvstr(&Arg1, sbuf1) == CvtFail) RunErr(103, &Arg1); if ((t = cvstr(&Arg2, sbuf2)) == CvtFail) RunErr(103, &Arg2); /* * lexcmp does the work. */ if (lexcmp(&Arg1, &Arg2) == Less) Fail; /* * Return Arg2 as the result of the comparison. If Arg2 was converted to * a string, a copy of it is allocated. */ Arg0 = Arg2; if (t == Cvt) { if (strreq(StrLen(Arg0)) == Error) RunErr(0, NULL); StrLoc(Arg0) = alcstr(StrLoc(Arg0), StrLen(Arg0)); } Return; } /* * x >> y - test if x is lexically greater than y. */OpDcl(lexgt,2,">>") { register int t; char sbuf1[MaxCvtLen], sbuf2[MaxCvtLen]; /* * Arg1 and Arg2 must be strings. Save the cvstr return value for Arg2 * because Arg2 is the result (if any). */ if (cvstr(&Arg1, sbuf1) == CvtFail) RunErr(103, &Arg1); if ((t = cvstr(&Arg2, sbuf2)) == CvtFail) RunErr(103, &Arg2); /* * lexcmp does the work. */ if (lexcmp(&Arg1, &Arg2) != Greater) Fail; /* * Return Arg2 as the result of the comparison. If Arg2 was converted to * a string, a copy of it is allocated. */ Arg0 = Arg2; if (t == Cvt) { if (strreq(StrLen(Arg0)) == Error) RunErr(0, NULL); StrLoc(Arg0) = alcstr(StrLoc(Arg0), StrLen(Arg0)); } Return; } /* * x <<= y - test if x is lexically less than or equal to y. */OpDcl(lexle,2,"<<=") { register int t; char sbuf1[MaxCvtLen], sbuf2[MaxCvtLen]; /* * Arg1 and Arg2 must be strings. Save the cvstr return value for Arg2 * because Arg2 is the result (if any). */ if (cvstr(&Arg1, sbuf1) == CvtFail) RunErr(103, &Arg1); if ((t = cvstr(&Arg2, sbuf2)) == CvtFail) RunErr(103, &Arg2); /* * lexcmp does the work. */ if (lexcmp(&Arg1, &Arg2) == Greater) Fail; /* * Return Arg2 as the result of the comparison. If Arg2 was converted to * a string, a copy of it is allocated. */ Arg0 = Arg2; if (t == Cvt) { if (strreq(StrLen(Arg0)) == Error) RunErr(0, NULL); StrLoc(Arg0) = alcstr(StrLoc(Arg0), StrLen(Arg0)); } Return; } /* * x << y - test if x is lexically less than y. */OpDcl(lexlt,2,"<<") { register int t; char sbuf1[MaxCvtLen], sbuf2[MaxCvtLen]; /* * Arg1 and Arg2 must be strings. Save the cvstr return value for Arg2 * because Arg2 is the result (if any). */ if (cvstr(&Arg1, sbuf1) == CvtFail) RunErr(103, &Arg1); if ((t = cvstr(&Arg2, sbuf2)) == CvtFail) RunErr(103, &Arg2); /* * lexcmp does the work. */ if (lexcmp(&Arg1, &Arg2) != Less) Fail; /* * Return Arg2 as the result of the comparison. If Arg2 was converted to * a string, a copy of it is allocated. */ Arg0 = Arg2; if (t == Cvt) { /* string needs to be allocated */ if (strreq(StrLen(Arg0)) == Error) RunErr(0, NULL); StrLoc(Arg0) = alcstr(StrLoc(Arg0), StrLen(Arg0)); } Return; } /* * x ~== y - test if x is lexically not equal to y. */OpDcl(lexne,2,"~==") { register int t; char sbuf1[MaxCvtLen], sbuf2[MaxCvtLen]; /* * Arg1 and Arg2 must be strings. Save the cvstr return value for Arg2 * because Arg2 is the result (if any). */ if (cvstr(&Arg1, sbuf1) == CvtFail) RunErr(103, &Arg1); if ((t = cvstr(&Arg2, sbuf2)) == CvtFail) RunErr(103, &Arg2); /* * If the strings have different lengths they are not equal. * If lengths are the same, let lexcmp do the work. */ if (StrLen(Arg1) == StrLen(Arg2) && lexcmp(&Arg1, &Arg2) == Equal) Fail; /* * Return Arg2 as the result of the comparison. If Arg2 was converted to * a string, a copy of it is allocated. */ Arg0 = Arg2; if (t == Cvt) { /* string needs to be allocated */ if (strreq(StrLen(Arg0)) == Error) RunErr(0, NULL); StrLoc(Arg0) = alcstr(StrLoc(Arg0), StrLen(Arg0)); } Return; } /* * x = y - test if x is numerically equal to y. */OpDcl(numeq,2,"=") { switch (numcmp(&Arg1, &Arg2, &Arg0)) { case Equal: Return; case Greater: case Less: Fail; case Error: RunErr(0, NULL); } } /* * x >= y - test if x is numerically greater or equal to y. */OpDcl(numge,2,">=") { switch (numcmp(&Arg1, &Arg2, &Arg0)) { case Greater: case Equal: Return; case Less: Fail; case Error: RunErr(0, NULL); } } /* * x > y - test if x is numerically greater than y. */OpDcl(numgt,2,">") { switch (numcmp(&Arg1, &Arg2, &Arg0)) { case Greater: Return; case Less: case Equal: Fail; case Error: RunErr(0, NULL); } } /* * x <= y - test if x is numerically less than or equal to y. */OpDcl(numle,2,"<=") { switch (numcmp(&Arg1, &Arg2, &Arg0)) { case Less: case Equal: Return; case Greater: Fail; case Error: RunErr(0, NULL); } } /* * x < y - test if x is numerically less than y. */OpDcl(numlt,2,"<") { switch (numcmp(&Arg1, &Arg2, &Arg0)) { case Less: Return; case Greater: case Equal: Fail; case Error: RunErr(0, NULL); } } /* * x ~= y - test if x is numerically not equal to y. */OpDcl(numne,2,"~=") { switch (numcmp(&Arg1, &Arg2, &Arg0)) { case Less: case Greater: Return; case Equal: Fail; case Error: RunErr(0, NULL); } Return; } /* * x === y - test equivalence of Arg1 and Arg2. */OpDcl(eqv,2,"===") { /* * Let equiv do all the work, failing if equiv indicates non-equivalence. */ if (!equiv(&Arg1, &Arg2)) Fail; Arg0 = Arg2; Return; } /* * x ~=== y - test inequivalence of Arg1 and Arg2. */OpDcl(neqv,2,"~===") { /* * equiv does all the work. */ if (equiv(&Arg1, &Arg2)) Fail; Arg0 = Arg2; Return; } :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:omisc.c
/* * File: omisc.c * Contents: refresh, size, tabmat, toby */#include "::h:config.h"#include "::h:rt.h"#include "rproto.h"#ifdef PreProcess/* include(../M4/ops.m4) /* *//* */#endif /* PreProcess *//* * ^x - return an entry block for co-expression x from the refresh block. */OpDcl(refresh,1,"^") {#ifdef Coexpr register struct b_coexpr *sblkp; register struct b_refresh *rblkp; register dptr dp, dsp; register word *newsp; int na, nl, i; /* * Be sure a co-expression is being refreshed. */ if (Qual(Arg1) || Arg1.dword != D_Coexpr) RunErr(118, &Arg1); /* * Get a new co-expression stack and initialize. */ if ((sblkp = alccoexp()) == NULL) RunErr(0, NULL); sblkp->freshblk = BlkLoc(Arg1)->coexpr.freshblk; if (ChkNull(sblkp->freshblk)) /* &main cannot be refreshed */ RunErr(215, &Arg1); /* * The interpreter stack starts at word after co-expression stack block. * C stack starts at end of stack region on machines with down-growing C * stacks and somewhere in the middle of the region. * * The C stack is aligned on a doubleword boundary. For upgrowing * stacks, the C stack starts in the middle of the stack portion * of the static block. For downgrowing stacks, the C stack starts * at the last word of the static block. */ newsp = (word *)((word)(char *)sblkp + sizeof(struct b_coexpr));#ifdef UpStack sblkp->cstate[0] = ((word)((word)(char *)sblkp + (stksize - sizeof(*sblkp))/2) &~(WordSize*StackAlign-1));#else /* UpStack */ sblkp->cstate[0] = ((word)((word)(char *)sblkp + stksize - WordSize)&~(WordSize*StackAlign-1));#endif /* UpStack */ sblkp->es_argp = (dptr)newsp; /* * Get pointer to refresh block and get number of arguments and locals. */ rblkp = (struct b_refresh *)BlkLoc(sblkp->freshblk); na = (rblkp->pfmkr).pf_nargs + 1; nl = (int)rblkp->numlocals; /* * Copy arguments onto new stack. */ dp = &rblkp->elems[0]; dsp = (dptr)newsp; for (i = 1; i <= na; i++) *dsp++ = *dp++; /* * Copy procedure frame to new stack and point dsp to word after frame. */ *((struct pf_marker *)dsp) = rblkp->pfmkr; sblkp->es_pfp = (struct pf_marker *)dsp;/* dsp = (dptr)((word *)dsp + Vwsizeof(*pfp)); */ dsp = (dptr)((word)dsp + sizeof(word) * Vwsizeof(*pfp)); sblkp->es_ipc.opnd = rblkp->ep; sblkp->es_gfp = 0; sblkp->es_efp = 0; sblkp->tvalloc = NULL; sblkp->es_ilevel = 0; /* * Copy locals to new stack and refresh block. */ for (i = 1; i <= nl; i++) *dsp++ = *dp++; /* * Push two null descriptors on the stack. */ *dsp++ = nulldesc; *dsp++ = nulldesc; sblkp->es_sp = (word *)dsp - 1; /* * Return the new co-expression. */ Arg0.dword = D_Coexpr; BlkLoc(Arg0) = (union block *) sblkp; Return;#else /* Coexpr */ RunErr(-401, NULL);#endif /* Coexpr */ } /* * *x - return size of string or object x. */OpDcl(size,1,"*") { char sbuf[MaxCvtLen]; word i; int j; union block *bp; if (Qual(Arg1)) { /* * If Arg1 is a string, return the length of the string. */ i = StrLen(Arg1); } else { /* * Arg1 is not a string. For most types, the size is in the size * field of the block. * structure. */ switch (Type(Arg1)) { case T_List: i = BlkLoc(Arg1)->list.size; break; case T_Table: i = BlkLoc(Arg1)->table.size; break; case T_Set: i = BlkLoc(Arg1)->set.size; break; case T_Cset: { register unsigned int w; i = BlkLoc(Arg1)->cset.size; if (i >= 0) break; bp = (union block *)BlkLoc(Arg1); i = 0; for (j = 0; j < CsetSize; j++) for (w=bp->cset.bits[j]; w; w >>= 1) if (w & 01) i++; bp->cset.size = i; break; } case T_Record: i = BlkLoc(Arg1)->record.recdesc->proc.nfields; break; case T_Coexpr: i = BlkLoc(Arg1)->coexpr.size; break; default: /* * Try to convert it to a string. */ if (cvstr(&Arg1, sbuf) == CvtFail) RunErr(112, &Arg1); /* no notion of size */ i = StrLen(Arg1); } } MakeInt(i, &Arg0); Return; } /* * =x - tab(match(x)). Reverses effects if resumed. */OpDcl(tabmat,1,"=") { register word l; register char *s1, *s2; word i, j; char sbuf[MaxCvtLen]; int type; /* * Arg1 must be a string. */ if ((type = cvstr(&Arg1,sbuf)) == CvtFail) RunErr(103, &Arg1); /* * Make a copy of &pos. */ i = k_pos; /* * Fail if &subject[&pos:0] is not of sufficient length to contain Arg1. */ j = StrLen(k_subject) - i + 1; if (j < StrLen(Arg1)) Fail; /* * Get pointers to Arg1 (s1) and &subject (s2). Compare them on a bytewise * basis and fail if s1 doesn't match s2 for *s1 characters. */ s1 = StrLoc(Arg1); s2 = StrLoc(k_subject) + i - 1; l = StrLen(Arg1); while (l-- > 0) { if (*s1++ != *s2++) Fail; } /* * Increment &pos to tab over the matched string and suspend the * matched string. */ l = StrLen(Arg1); k_pos += l; Arg0 = Arg1; if (type == Cvt) { /* string is in buffer, copy */ if (strreq(StrLen(Arg0)) == Error) RunErr(0, NULL); StrLoc(Arg0) = alcstr(StrLoc(Arg0), StrLen(Arg0)); } Suspend; /* * tabmat has been resumed, restore &pos and fail. */ if (i > StrLen(k_subject) + 1) { RunErr(205, &tvky_pos.kyval); } else k_pos = i; Fail; } /* * i to j by k - generate successive values. */OpDcl(toby,3,"...") { long from; /* * Arg1 (from), Arg2 (to), and Arg3 (by) must be integers. * Also, Arg3 must not be zero. */ if (cvint(&Arg1) == CvtFail) RunErr(101, &Arg1); if (cvint(&Arg2) == CvtFail) RunErr(101, &Arg2); if (cvint(&Arg3) == CvtFail) RunErr(101, &Arg3); if (IntVal(Arg3) == 0) RunErr(211, &Arg3); /* * Count up or down (depending on relationship of from and to) and * suspend each value in sequence, failing when the limit has been * exceeded. */ from = IntVal(Arg1); if (IntVal(Arg3) > 0) for ( ; from <= IntVal(Arg2); from += IntVal(Arg3)) { MakeInt(from, &Arg0); Suspend; } else for ( ; from >= IntVal(Arg2); from += IntVal(Arg3)) { MakeInt(from, &Arg0); Suspend; } Fail; } :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:oref.c
/* * File: oref.c * Contents: bang, random, sect, subsc */#include "::h:config.h"#include "::h:rt.h"#include "rproto.h"#ifdef PreProcess/* include(../M4/ops.m4) /* *//* */#endif /* PreProcess *//* * !x - generate successive values from object x. */OpDcl(bang,1,"!") { register word i, j, slen, rlen; register union block *bp; register dptr dp; register char *sp; int typ1; char sbuf[MaxCvtLen]; FILE *fd; Arg2 = Arg1; if (DeRef(Arg1) == Error) RunErr(0, NULL); if ((typ1 = cvstr(&Arg1, sbuf)) != CvtFail) { /* * A string is being banged. */ i = 1; while (i <= StrLen(Arg1)) { /* * Loop through the string using i as an index. */ if (typ1 == Cvt) { /* * Arg1 was converted to a string, thus, the resulting string * cannot be modified and a trapped variable is not needed. * Make a one-character string out of the next character * in Arg1 and suspend it. */ if (strreq((word)1) == Error) RunErr(0, NULL); StrLen(Arg0) = 1; StrLoc(Arg0) = alcstr(StrLoc(Arg1)+i-1, (word)1); Suspend; } else { /* * Arg1 is a string and thus a trapped variable must be made * for the one character string being suspended. */ if (blkreq((word)sizeof(struct b_tvsubs)) == Error) RunErr(0, NULL); mksubs(&Arg2, &Arg1, i, (word)1, &Arg0); Suspend; Arg1 = Arg2; if (DeRef(Arg1) == Error) RunErr(0, NULL); if (!Qual(Arg1)) RunErr(103, &Arg1); } i++; } } else { /* * Arg1 is not a string. */ switch (Type(Arg1)) { case T_List: /* * Arg1 is a list. Chain through each list element block and for * each onnd with a variable pointing to each * element contained in the block. */ bp = BlkLoc(Arg1); for (bp = bp->list.listhead; bp != NULL; bp = bp->lelem.listnext) { for (i = 0; i < bp->lelem.nused; i++) { j = bp->lelem.first + i; if (j >= bp->lelem.nslots) j -= bp->lelem.nslots; dp = &bp->lelem.lslots[j]; Arg0.dword = D_Var + ((word *)dp - (word *)bp); VarLoc(Arg0) = (dptr)bp; BlkLoc(Arg1) = bp; /* save in Arg1 since bp is untended */ Suspend; bp = BlkLoc(Arg1); /* bp is untended, must reset */ } } break; case T_File: /* * Arg1 is a file. Read the next line into the string space * and suspend the newly allocated string. */ fd = BlkLoc(Arg1)->file.fd; if ((BlkLoc(Arg1)->file.status & Fs_Read) == 0) RunErr(212, &Arg1); for (;;) { StrLen(Arg0) = 0; do { if ((slen = getstrg(sbuf,MaxCvtLen,fd)) == -1) Fail; rlen = slen < 0 ? (word)MaxCvtLen : slen; if (strreq(rlen) == Error) RunErr(0, NULL); sp = alcstr(sbuf,rlen); if (StrLen(Arg0) == 0) StrLoc(Arg0) = sp; StrLen(Arg0) += rlen; } while (slen < 0); Suspend; } break; case T_Table: /* * Arg1 is a table. Generate the element values. */ MakeInt(2, &Arg2); /* indicate that we want the values */ Forward(hgener); /* go to the hash generator */ case T_Set: /* * Arg1 is a set. Generate the element values. */ MakeInt(0, &Arg2); /* indicate that we want set elements */ Forward(hgener); /* go to the hash generator */ case T_Record: /* * Arg1 is a record. Loop through the fields and suspend * a variable pointing to each one. */ bp = BlkLoc(Arg1); j = bp->record.recdesc->proc.nfields; for (i = 0; i < j; i++) { dp = &bp->record.fields[i]; Arg0.dword = D_Var + ((word *)dp - (word *)bp); VarLoc(Arg0) = (dptr)bp; Suspend; bp = BlkLoc(Arg1); /* bp is untended, must reset */ } break; default: /* This object can not be compromised. */ RunErr(116, &Arg1); } } /* * Eventually fail. */ Fail; } #define RandVal (RanScale*(k_random=(RandA*k_random+RandC)&MaxLong))/* * ?x - produce a randomly selected element of x. */OpDcl(random,1,"?") { register word val, i, j, n; register union block *bp, *ep; struct b_slots *seg; char sbuf[MaxCvtLen]; dptr dp; double rval; Arg2 = Arg1; if (DeRef(Arg1) == Error) RunErr(0, NULL); if (Qual(Arg1)) { /* * Arg1 is a string, produce a random character in it as the result. * Note that a substring trapped variable is returned. */ if ((val = StrLen(Arg1)) <= 0) Fail; if (blkreq((word)sizeof(struct b_tvsubs)) == Error) RunErr(0, NULL); rval = RandVal; /* This form is used to get around */ rval *= val; /* a bug in a certain C compiler */ mksubs(&Arg2, &Arg1, (word)rval + 1, (word)1, &Arg0); Return; } switch (Type(Arg1)) { case T_Cset: /* * Arg1 is a cset. Convert it to a string, select a random character * of that string and return it. Note that a substring trapped * variable is not needed. */ cvstr(&Arg1, sbuf); if ((val = StrLen(Arg1)) <= 0) Fail; if (strreq((word)1) == Error) RunErr(0, NULL); StrLen(Arg0) = 1; rval = RandVal; rval *= val; StrLoc(Arg0) = alcstr(StrLoc(Arg1)+(word)rval, (word)1); Return; case T_List: /* * Arg1 is a list. Set i to a random number in the range [1,*Arg1], * failing if the list is empty. */ bp = BlkLoc(Arg1); val = bp->list.size; if (val <= 0) Fail; rval = RandVal; rval *= val; i = (word)rval + 1; j = 1; /* * Work down chain list of list blocks and find the block that * contains the selected element. */ bp = bp->list.listhead; while (i >= j + bp->lelem.nused) { j += bp->lelem.nused; bp = bp->lelem.listnext; if (bp == NULL) syserr("list reference out of bounds in random"); } /* * Locate the appropriate element and return a variable * that points to it. */ i += bp->lelem.first - j; if (i >= bp->lelem.nslots) i -= bp->lelem.nslots; dp = &bp->lelem.lslots[i]; Arg0.dword = D_Var + ((word *)dp - (word *)bp); VarLoc(Arg0) = (dptr)bp; Return; case T_Table: case T_Set: /* * Arg1 is a table or a set. Set n to a random number in the range * [1,*Arg1], failing if the structure is empty. */ bp = BlkLoc(Arg1); val = bp->table.size; if (val <= 0) Fail; rval = RandVal; rval *= val; n = (word)rval + 1; /* * Walk down the hash chains to find and return the n'th element. */ for (i = 0; i < HSegs && (seg = bp->table.hdir[i]) != NULL; i++) for (j = segsize[i] - 1; j >= 0; j--) for (ep = seg->hslots[j]; ep != NULL; ep = ep->telem.clink) if (--n <= 0) { if (Type(Arg1) == T_Set) { /* * For a set, return the element value. */ Arg0 = ep->selem.setmem; } else { /* * For a table, return a variable pointing to the * selected element. */ dp = &ep->telem.tval; Arg0.dword = D_Var + ((word *)dp - (word *)bp); VarLoc(Arg0) = (dptr)bp; } Return; } case T_Record: /* * Arg1 is a record. Set val to a random number in the range * [1,*Arg1] (*Arg1 is the number of fields), failing if the * record has no fields. */ bp = BlkLoc(Arg1); val = bp->record.recdesc->proc.nfields; if (val <= 0) Fail; /* * Locate the selected element and return a variable * that points to it */ rval = RandVal; rval *= val; dp = &bp->record.fields[(word)rval]; Arg0.dword = D_Var + ((word *)dp - (word *)bp); VarLoc(Arg0) = (dptr)bp; Return;#ifdef LargeInts case T_Bignum: if (bigrand(&Arg1, &Arg0) == Error) /* alcbignum failed */ RunErr(0, NULL); Return;#endif /* LargeInts */ default: /* * Try converting it to an integer */ switch (cvint(&Arg1)) { case T_Integer: /* * Arg1 is an integer, be sure that it's non-negative. */ val = (word)IntVal(Arg1); if (val < 0) RunErr(205, &Arg1); /* * val contains the integer value of Arg1. If val is 0, return * a real in the range [0,1], else return an integer in the * range [1,val]. */ if (val == 0) { rval = RandVal; if (makereal(rval, &Arg0) == Error) RunErr(0, NULL); } else { rval = RandVal; rval *= val; MakeInt((long)rval + 1, &Arg0); } Return; default: /* * Arg1 is of a type for which random generation is not supported */ RunErr(113, &Arg1); } } } /* * x[i:j] - form a substring or list section of x. */OpDcl(sect,3,"[:]") { register word i, j, t; int typ1; char sbuf[MaxCvtLen]; if (blkreq((word)sizeof(struct b_tvsubs)) == Error) RunErr(0, NULL); if (cvint(&Arg2) == CvtFail) RunErr(101, &Arg2); if (cvint(&Arg3) == CvtFail) RunErr(101, &Arg3); Arg4 = Arg1; if (DeRef(Arg1) == Error) RunErr(0, NULL); if (Arg1.dword == D_List) { i = cvpos(IntVal(Arg2), BlkLoc(Arg1)->list.size); if (i == CvtFail) Fail; j = cvpos(IntVal(Arg3), BlkLoc(Arg1)->list.size); if (j == CvtFail) Fail; if (i > j) { t = i; i = j; j = t; } if (cplist(&Arg1, &Arg0, i, j) == Error) RunErr(0, NULL); Return; } if ((typ1 = cvstr(&Arg1, sbuf)) == CvtFail) RunErr(110, &Arg1); i = cvpos(IntVal(Arg2), StrLen(Arg1)); if (i == CvtFail) Fail; j = cvpos(IntVal(Arg3), StrLen(Arg1)); if (j == CvtFail) Fail; if (i > j) { /* convert section to substring */ t = i; i = j; j = t - j; } else j = j - i; if (typ1 == Cvt) { /* * A string was created - just return a string */ if (strreq(j) == Error) RunErr(0, NULL); StrLen(Arg0) = j; StrLoc(Arg0) = alcstr(StrLoc(Arg1)+i-1, j); } else /* else make a substring tv */ mksubs(&Arg4, &Arg1, i, j, &Arg0); Return; } /* * x[y] - access yth character or element of x. */OpDcl(subsc,2,"[]") { register word i, j; register union block *bp; register uword hn; int typ1, res; dptr dp; union block **dp1; char sbuf[MaxCvtLen]; /* * Make a copy of Arg1. */ Arg3 = Arg1; if (DeRef(Arg1) == Error) RunErr(0, NULL); if ((typ1 = cvstr(&Arg1, sbuf)) != CvtFail) { /* * Arg1 is a string, make sure that Arg2 is an integer. */ if (cvint(&Arg2) == CvtFail) RunErr(101, &Arg2); /* * Convert Arg2 to a position in Arg1 and fail if the position is out * of bounds. */ i = cvpos(IntVal(Arg2), StrLen(Arg1)); if (i == CvtFail || i > StrLen(Arg1)) Fail; if (typ1 == Cvt) { /* * Arg1 was converted to a string, so it cannot be assigned back into. * Just return a string containing the selected character. */ if (strreq((word)1) == Error) RunErr(0, NULL); StrLen(Arg0) = 1; StrLoc(Arg0) = alcstr(StrLoc(Arg1)+i-1, (word)1); } else { /* * Arg1 is a string, make a substring trapped variable for the one * character substring selected and return it. */ if (blkreq((word)sizeof(struct b_tvsubs)) == Error) RunErr(0, NULL); mksubs(&Arg3, &Arg1, i, (word)1, &Arg0); } Return; } /* * Arg1 is not a string or convertible to one, see if it's an aggregate. */ switch (Type(Arg1)) { case T_List: /* * Make sure that Arg2 is an integer and that the * subscript is in range. */ if (cvint(&Arg2) == CvtFail) RunErr(101, &Arg2); i = cvpos(IntVal(Arg2), BlkLoc(Arg1)->list.size); if (i == CvtFail || i > BlkLoc(Arg1)->list.size) Fail; /* * Locate the list-element block containing the desired * element. */ bp = BlkLoc(Arg1)->list.listhead; j = 1; while (bp != NULL && i >= j + bp->lelem.nused) { j += bp->lelem.nused; bp = bp->lelem.listnext; } /* * Locate the desired element and return a pointer to it. */ i += bp->lelem.first - j; if (i >= bp->lelem.nslots) i -= bp->lelem.nslots; dp = &bp->lelem.lslots[i]; Arg0.dword = D_Var + ((word *)dp - (word *)bp); VarLoc(Arg0) = (dptr)bp; Return; case T_Table: /* * Arg1 is a table. Locate the appropriate bucket * based on the hash value. */ if (blkreq((word)sizeof(struct b_tvtbl)) == Error) RunErr(0, NULL); hn = hash(&Arg2); dp1 = memb(BlkLoc(Arg1), &Arg2, hn, &res); if (res == 1) { bp = *dp1; dp = &bp->telem.tval; Arg0.dword = D_Var + ((word *)dp - (word *)bp); VarLoc(Arg0) = (dptr)bp; } else { /* * Arg1[Arg2] is not in the table, make a table element trapped * variable and return it as the result. */ Arg0.dword = D_Tvtbl; BlkLoc(Arg0) = (union block *)alctvtbl(&Arg1, &Arg2, hn); } Return; case T_Record: /* * Arg1 is a record. Convert Arg2 to an integer and be sure that it * it is in range as a field number. */ if (cvint(&Arg2) == CvtFail) RunErr(101, &Arg2); bp = BlkLoc(Arg1);
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:oref.c
+++++ Continued from previous card +++++
i = cvpos(IntVal(Arg2), (word)(bp->record.recdesc->proc.nfields)); if (i == CvtFail || i > bp->record.recdesc->proc.nfields) Fail; /* * Locate the appropriate field and return a pointer to it. */ dp = &bp->record.fields[i-1]; Arg0.dword = D_Var + ((word *)dp - (word *)bp); VarLoc(Arg0) = (dptr)bp; Return; default: /* * Arg1 is of a type that cannot be subscripted. */ RunErr(114, &Arg1); } } :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:oset.c
/* * File: oset.c * Contents: compl, diff, inter, unions */#include "::h:config.h"#include "::h:rt.h"#include "rproto.h"#ifdef PreProcess/* include(../M4/ops.m4) /* *//* */#endif /* PreProcess *//* * ~x - complement cset x. */OpDcl(compl,1,"~") { register int i; union block *bp; int *cs, csbuf[CsetSize]; if (blkreq((word)sizeof(struct b_cset)) == Error) RunErr(0, NULL); /* * Arg1 must be a cset. */ if (cvcset(&Arg1, &cs, csbuf) == CvtFail) RunErr(104, &Arg1); /* * Allocate a new cset and then copy each cset word from Arg1 * into the new cset words, complementing each bit. */ bp = (union block *)alccset(); for (i = 0; i < CsetSize; i++) bp->cset.bits[i] = ~cs[i]; Arg0.dword = D_Cset; BlkLoc(Arg0) = bp; Return; } /* * x -- y - difference of csets x and y or of sets x and y. */OpDcl(diff,2,"--") { register word i; word slotnum; register union block *srcp, *tstp, *dstp, **hook; int *cs1, *cs2, csbuf1[CsetSize], csbuf2[CsetSize], res; struct b_slots *seg; struct b_selem *ep; if (Qual(Arg1) || Qual(Arg2)) goto skipsets; if (Arg1.dword == D_Set && Arg2.dword != D_Set) RunErr(119, &Arg2); if (Arg2.dword == D_Set && Arg1.dword != D_Set) RunErr(119, &Arg1); if (Arg1.dword == D_Set && Arg2.dword == D_Set) { /* * Both Arg1 and Arg2 are sets - do set difference. Make a new set * based on the size of Arg1. */ dstp = hmake(T_Set, (word)0, BlkLoc(Arg1)->set.size); if (dstp == NULL) RunErr(0, NULL); /* * For each element in set Arg1 if it is not in set Arg2 * copy it directly into the result set. */ srcp = BlkLoc(Arg1); tstp = BlkLoc(Arg2); for (i = 0; i < HSegs && (seg = srcp->set.hdir[i]) != NULL; i++) for (slotnum = segsize[i] - 1; slotnum >= 0; slotnum--) { ep = (struct b_selem *)seg->hslots[slotnum]; while (ep != NULL) { memb(tstp, &ep->setmem, ep->hashnum, &res); if (res == 0) { hook = memb(dstp, &ep->setmem, ep->hashnum, &res); addmem(&dstp->set, alcselem(&ep->setmem, ep->hashnum), hook); } ep = (struct b_selem *)ep->clink; } } Arg0.dword = D_Set; BlkLoc(Arg0) = dstp; if (TooSparse(dstp)) hshrink(&Arg0); } else { skipsets: if (blkreq((word)sizeof(struct b_cset)) == Error) RunErr(0, NULL); /* * Arg1 and Arg2 must be csets. */ if (cvcset(&Arg1, &cs1, csbuf1) == CvtFail) RunErr(120, &Arg1); if (cvcset(&Arg2, &cs2, csbuf2) == CvtFail) RunErr(120, &Arg2); /* * Allocate a new cset and in each word of it, compute the value * of the bitwise difference of the corresponding words in the * Arg1 and Arg2 csets. */ dstp = (union block *)alccset(); for (i = 0; i < CsetSize; i++) { dstp->cset.bits[i] = cs1[i] & ~cs2[i]; } Arg0.dword = D_Cset; BlkLoc(Arg0) = dstp; } Return; } /* * x ** y - intersection of csets x and y or of sets x and y. */OpDcl(inter,2,"**") { register word i; word slotnum; register union block *srcp, *tstp, *dstp, **hook; int *cs1, *cs2, csbuf1[CsetSize], csbuf2[CsetSize], res; struct b_slots *seg; struct b_selem *ep; if (Qual(Arg1) || Qual(Arg2)) goto skipsets; if (Arg1.dword == D_Set && Arg2.dword != D_Set) RunErr(119, &Arg2); if (Arg2.dword == D_Set && Arg1.dword != D_Set) RunErr(119, &Arg1); if (Arg1.dword == D_Set && Arg2.dword == D_Set) { /* * Both Arg1 and Arg2 are sets - do set intersection. * Make a new set the size of the smaller argument set. */ dstp = hmake(T_Set, (word)0, Min(BlkLoc(Arg1)->set.size, BlkLoc(Arg2)->set.size)); if (dstp == NULL) RunErr(0, NULL); /* * Using the smaller of the two sets as the source * copy directly into the result each of its elements * that are also members of the other set. */ if (BlkLoc(Arg1)->set.size <= BlkLoc(Arg2)->set.size) { srcp = BlkLoc(Arg1); tstp = BlkLoc(Arg2); } else { srcp = BlkLoc(Arg2); tstp = BlkLoc(Arg1); } for (i = 0; i < HSegs && (seg = srcp->set.hdir[i]) != NULL; i++) for (slotnum = segsize[i] - 1; slotnum >= 0; slotnum--) { ep = (struct b_selem *)seg->hslots[slotnum]; while (ep != NULL) { memb(tstp, &ep->setmem, ep->hashnum, &res); if (res != 0) { hook = memb(dstp, &ep->setmem, ep->hashnum, &res); addmem(&dstp->set, alcselem(&ep->setmem, ep->hashnum), hook); } ep = (struct b_selem *)ep->clink; } } Arg0.dword = D_Set; BlkLoc(Arg0) = dstp; if (TooSparse(dstp)) hshrink(&Arg0); } else { skipsets: if (blkreq((word)sizeof(struct b_cset)) == Error) RunErr(0, NULL); /* * Arg1 and Arg2 must be csets. */ if (cvcset(&Arg1, &cs1, csbuf1) == CvtFail) RunErr(120, &Arg1); if (cvcset(&Arg2, &cs2, csbuf2) == CvtFail) RunErr(120, &Arg2); /* * Allocate a new cset and in each word of it, compute the value * of the bitwise intersection of the corresponding words in the * Arg1 and Arg2 csets. */ dstp = (union block *)alccset(); for (i = 0; i < CsetSize; i++) { dstp->cset.bits[i] = cs1[i] & cs2[i]; } Arg0.dword = D_Cset; BlkLoc(Arg0) = dstp; } Return; } /* * x ++ y - union of csets x and y or of sets x and y. */OpDcl(unions,2,"++") { register word i; word slotnum; register union block *srcp, *tstp, *dstp, **hook; int *cs1, *cs2, csbuf1[CsetSize], csbuf2[CsetSize], res; struct b_slots *seg; struct b_selem *ep; dptr srcd, tstd; if (Qual(Arg1) || Qual(Arg2)) goto skipsets; if (Arg1.dword == D_Set && Arg2.dword != D_Set) RunErr(119, &Arg2); if (Arg2.dword == D_Set && Arg1.dword != D_Set) RunErr(119, &Arg1); if (Arg1.dword == D_Set && Arg2.dword == D_Set) { /* * Both Arg1 and Arg2 are sets - do set union. Copy the larger set * and ensure there's room for *Arg1 + *Arg2 elements. */ if (BlkLoc(Arg1)->set.size >= BlkLoc(Arg2)->set.size) { srcd = &Arg1; tstd = &Arg2; } else { srcd = &Arg2; tstd = &Arg1; } if (cpset(srcd, &Arg0, BlkLoc(Arg1)->set.size + BlkLoc(Arg2)->set.size) == Error) RunErr(0, NULL); /* * Copy each element from the smaller set into the result set, * if it is not already there. */ srcp = BlkLoc(*srcd); tstp = BlkLoc(*tstd); dstp = BlkLoc(Arg0); for (i = 0; i < HSegs && (seg = tstp->set.hdir[i]) != NULL; i++) for (slotnum = segsize[i] - 1; slotnum >= 0; slotnum--) { ep = (struct b_selem *)seg->hslots[slotnum]; while (ep != NULL) { hook = memb(dstp, &ep->setmem, ep->hashnum, &res); if (res == 0) addmem(&dstp->set, alcselem(&ep->setmem, ep->hashnum), hook); ep = (struct b_selem *)ep->clink; } } if (TooCrowded(dstp)) /* if the union got too big, enlarge */ hgrow(&Arg0); } else { skipsets: if (blkreq((word)sizeof(struct b_cset)) == Error) RunErr(0, NULL); /* * Arg1 and Arg2 must be csets. */ if (cvcset(&Arg1, &cs1, csbuf1) == CvtFail) RunErr(120, &Arg1); if (cvcset(&Arg2, &cs2, csbuf2) == CvtFail) RunErr(120, &Arg2); /* * Allocate a new cset and in each word of it, compute the value * of the bitwise union of the corresponding words in the * Arg1 and Arg2 csets. */ dstp = (union block *)alccset(); for (i = 0; i < CsetSize; i++) { dstp->cset.bits[i] = cs1[i] | cs2[i]; } Arg0.dword = D_Cset; BlkLoc(Arg0) = dstp; } Return; } :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:ovalue.c
/* * File: ovalue.c * Contents: nonnull, null, value */#include "::h:config.h"#include "::h:rt.h"#include "rproto.h"#ifdef PreProcess/* include(../M4/ops.m4) /* *//* */#endif /* PreProcess *//* * \x - test x for nonnull value. */#ifdef WATERLOO_C_V3_0struct b_iproc Bnonnull = { T_Proc, Vsizeof(struct b_proc), Ononnull, 1, -1, 0, 0, {sizeof(BackSlash)-1,BackSlash}}; Ononnull(cargp,sptr) register dptr cargp;#else /* WATERLOO_C_V3_0 */OpDcl(nonnull,1,BackSlash)#endif /* WATERLOO_C_V3_0 */ { /* * If Arg1 is not null, it is returned, otherwise, the function fails. * Because the pre-dereference value of Arg1 is the return value (if * any), Arg1 is copied into Arg0. */ Arg0 = Arg1; if (DeRef(Arg1) == Error) RunErr(0, NULL); if (ChkNull(Arg1)) Fail; Return; } /* * /x - test x for null value. */OpDcl(null,1,"/") { /* * If Arg1 is null, it is returned, otherwise, the function fails. * Because the pre-dereference value of Arg1 is the return value (if * any), Arg1 is copied into Arg0. */ Arg0 = Arg1; if (DeRef(Arg1) == Error) RunErr(0, NULL); if (!ChkNull(Arg1)) Fail; Return; } /* * .x - produce value of x. */OpDcl(value,1,".") { if (DeRef(Arg1) == Error) RunErr(0, NULL); Arg0 = Arg1; Return; } :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:rcomp.c
/* * File: rcomp.c * Contents: anycmp, equiv, lexcmp, numcmp */#include "::h:config.h"#include "::h:rt.h"#include "rproto.h"/* * anycmp - compare any two objects. */int anycmp(dp1,dp2)dptr dp1, dp2; { register int o1, o2; register long lresult; double rres1, rres2, rresult; /* * Get a collating number for dp1 and dp2. */ o1 = order(dp1); o2 = order(dp2); /* * If dp1 and dp2 aren't of the same type, compare their collating numbers. */ if (o1 != o2) return (o1 > o2 ? Greater : Less); if (o1 == 3) /* * dp1 and dp2 are strings, use lexcmp to compare them. */ return lexcmp(dp1,dp2); switch (Type(*dp1)) { case T_Integer: lresult = IntVal(*dp1) - IntVal(*dp2); if (lresult == 0) return Equal; return ((lresult > 0) ? Greater : Less);#ifdef LargeInts case T_Bignum: lresult = bigcmp(dp1, dp2); if (lresult == 0) return Equal; return ((lresult > 0) ? Greater : Less);#endif /* LargeInts */ case T_Real: GetReal(dp1,rres1); GetReal(dp2,rres2); rresult = rres1 - rres2; if (rresult == 0.0) return Equal; return ((rresult > 0.0) ? Greater : Less); case T_Null: return Equal; case T_Cset: return csetcmp((unsigned int *)((struct b_cset *)BlkLoc(*dp1))->bits, (unsigned int *)((struct b_cset *)BlkLoc(*dp2))->bits); case T_File: case T_Proc: case T_List: case T_Table: case T_Set: case T_Record: case T_Coexpr: case T_External: /* * Collate these values according to the relative positions of * their blocks in the heap. */ lresult = ((long)BlkLoc(*dp1) - (long)BlkLoc(*dp2)); if (lresult == 0) return Equal; return ((lresult > 0) ? Greater : Less); default: syserr("anycmp: unknown datatype."); } } /* * order(x) - return collating number for object x. */int order(dp)dptr dp; { if (Qual(*dp)) return 3; /* string */ switch (Type(*dp)) { case T_Null: return 0; case T_Integer: return 1;#ifdef LargeInts case T_Bignum: return 1;#endif /* LargeInts */ case T_Real: return 2; case T_Cset: return 4; case T_Coexpr: return 5; case T_File: return 6; case T_Proc: return 7; case T_List: return 8; case T_Table: return 9; case T_Set: return 10; case T_Record: return 11; case T_External: return 12; default: syserr("order: unknown datatype."); } } /* * equiv - test equivalence of two objects. */int equiv(dp1, dp2)dptr dp1, dp2; { register int result; register word i; register char *s1, *s2; double rres1, rres2; result = 0; /* * If the descriptors are identical, the objects are equivalent. */ if (EqlDesc(*dp1,*dp2)) result = 1; else if (Qual(*dp1) && Qual(*dp2)) { /* * If both are strings of equal length, compare their characters. */ if ((i = StrLen(*dp1)) == StrLen(*dp2)) { s1 = StrLoc(*dp1); s2 = StrLoc(*dp2); result = 1; while (i--) if (*s1++ != *s2++) { result = 0; break; } } } else if (dp1->dword == dp2->dword) switch (Type(*dp1)) { /* * For integers and reals, just compare the values. */ case T_Integer: result = (IntVal(*dp1) == IntVal(*dp2)); break;#ifdef LargeInts case T_Bignum: result = (bigcmp(dp1, dp2) == 0); break;#endif /* LargeInts */ case T_Real: GetReal(dp1, rres1); GetReal(dp2, rres2); result = (rres1 == rres2); break; case T_Cset: /* * Compare the bit arrays of the csets. */ result = 1; for (i = 0; i < CsetSize; i++) if (BlkLoc(*dp1)->cset.bits[i] != BlkLoc(*dp2)->cset.bits[i]) { result = 0; break; } } else /* * dp1 and dp2 are of different types, so they can't be * equivalent. */ result = 0; return result; } /* * lexcmp - lexically compare two strings. */int lexcmp(dp1, dp2)dptr dp1, dp2; { register char *s1, *s2; register word minlen; word l1, l2; /* * Get length and starting address of both strings. */ l1 = StrLen(*dp1); s1 = StrLoc(*dp1); l2 = StrLen(*dp2); s2 = StrLoc(*dp2); /* * Set minlen to length of the shorter string. */ minlen = Min(l1, l2); /* * Compare as many bytes as are in the smaller string. If an * inequality is found, compare the differing bytes. */ while (minlen--) if (*s1++ != *s2++) return ((*--s1 & 0377) > (*--s2 & 0377) ? Greater : Less); /* * The strings compared equal for the length of the shorter. */ if (l1 == l2) return Equal; else if (l1 > l2) return Greater; else return Less; } /* * numcmp - compare two numbers. Returns -1, 0, 1 for dp1 <, =, > dp2. * dp3 is made into a descripthe return value. */int numcmp(dp1, dp2, dp3)dptr dp1, dp2, dp3; { int t1, t2; double r1, r2; /* * Be sure that both dp1 and dp2 are numeric. */ if ((t1 = cvnum(dp1)) == CvtFail) RetError(102, *dp1); if ((t2 = cvnum(dp2)) == CvtFail) RetError(102, *dp2); if (t1 == T_Integer && t2 == T_Integer) { /* * dp1 and dp2 are both integers, compare them and * create an integer descriptor in dp3 */ *dp3 = *dp2; if (IntVal(*dp1) == IntVal(*dp2)) return Equal; return ((IntVal(*dp1) > IntVal(*dp2)) ? Greater : Less); } else if (t1 == T_Real || t2 == T_Real) { /* * Either dp1 or dp2 is real. Convert the other to a real, * compare them and create a real descriptor in dp3. */ if (t1 != T_Real) {#ifdef LargeInts if (t1 == T_Bignum) r1 = bigtoreal(dp1); else#endif /* LargeInts */#ifdef WATERLOO_C_V3_0 { long int l; double d; d = IntVal(*dp1); r1 = d; }#else /* WATERLOO_C_V3_0 */ r1 = IntVal(*dp1);#endif /* WATERLOO_C_V3_0 */ } else r1 = BlkLoc(*dp1)->realblk.realval; if (t2 != T_Real) {#ifdef LargeInts if (t2 == T_Bignum) r2 = bigtoreal(dp2); else#endif /* LargeInts */#ifdef WATERLOO_C_V3_0 { long int l; double d; d = IntVal(*dp2); r2 = d; }#else /* WATERLOO_C_V3_0 */ r2 = IntVal(*dp2);#endif /* WATERLOO_C_V3_0 */ } else r2 = BlkLoc(*dp2)->realblk.realval; if (makereal(r2, dp3) == Error) return Error; if (r1 == r2) return Equal; return ((r1 > r2) ? Greater : Less); }#ifdef LargeInts else { int result; *dp3 = *dp2; result = bigcmp(dp1, dp2); if (result == 0) return Equal; return ((result > 0) ? Greater : Less); }#endif /* LargeInts */ } /* * csetcmp - compare two cset bit arrays. * The order defined by this function is identical to the lexical order of * the two strings that the csets would be converted into. */int csetcmp(cs1, cs2)unsigned int *cs1, *cs2; { unsigned int nbit, mask, *cs_end; if (cs1 == cs2) return Equal; /* * The longest common prefix of the two bit arrays converts to some * common prefix string. The first bit on which the csets disagree is * the first character of the conversion strings that disagree, and so this * is the character on which the order is determined. The cset that has * this first non-common bit = one, has in that position the lowest * character, so this cset is lexically least iff the other cset has some * following bit set. If the other cset has no bits set after the first * point of disagreement, then it is a prefix of the other, and is therefor * lexically less. * * Find the first word where cs1 and cs2 are different. */ for (cs_end = cs1 + CsetSize; cs1 < cs_end; cs1++, cs2++) if (*cs1 != *cs2) { /* * Let n be the position at which the bits first differ within * the word. Set nbit to some integer for which the nth bit * is the first bit in the word that is one. Note here and in the * following, that bits go from right to left within a word, so * the _first_ bit is the _rightmost_ bit. */ nbit = *cs1 ^ *cs2; /* Set mask to an integer that has all zeros in bit positions * upto and including position n, and all ones in bit positions * _after_ bit position n. */ for (mask = (unsigned)MaxLong << 1; !(~mask & nbit); mask <<= 1); /* * nbit & ~mask contains zeros everywhere except position n, which * is a one, so *cs2 & (nbit & ~mask) is non-zero iff the nth bit * of *cs2 is one. */ if (*cs2 & (nbit & ~mask)) { /* * If there are bits set in cs1 after bit position n in the * current word, then cs1 is lexically greater than cs2. */ if (*cs1 & mask) return Greater; while (++cs1 < cs_end) if (*cs1) return Greater; /* * Otherwise cs1 is a proper prefix of cs2 and is therefore * lexically less. */ return Less; } /* * If the nth bit of *cs2 isn't one, then the nth bit of cs1 * must be one. Just reverse the logic for the previous * case. */ if (*cs2 & mask) return Less; cs_end = cs2 + (cs_end - cs1); while (++cs2 < cs_end) if (*cs2) return Less; return Greater; } return Equal; } :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:rconv.c
/* * File: rconv.c * Contents: cvcset, cvint, cvnum, cvpos, cvreal, cvstr, mkint, * makereal, mksubs, strprc */#include <math.h>#include "::h:config.h"#include "::h:rt.h"#include "rproto.h"/* * Prototypes. */hidden int cstos Params((int *cs,dptr dp,char *s));hidden int itos Params((long num,dptr dp,char *s));hidden int ston Params((char *s,dptr dp));#ifndef LargeIntshidden int radix Params((int sign,int r,char *s,dptr dp));#endif /* LargeInts */#ifdef StrInvokeextern struct pstrnm pntab[];#endif /* StrInvoke */#include <ctype.h>#if !EBCDIC#define tonum(c) (isdigit(c) ? (c)-'0' : 10+(((c)|(040))-'a'))#endif /* !EBCDIC */ /* * cvcset(dp, cs, csbuf) - convert dp to a cset and * make cs point to it, using csbuf as a buffer if necessary. */int cvcset(dp, cs, csbuf)register dptr dp;int **cs, *csbuf; { register char *s; register word l; char sbuf[MaxCvtLen]; if (dp->dword == D_Cset) { *cs = BlkLoc(*dp)->cset.bits; return T_Cset; } if (cvstr(dp, sbuf) == CvtFail) return CvtFail; for (l = 0; l < CsetSize; l++) csbuf[l] = 0; s = StrLoc(*dp); l = StrLen(*dp); while (l--) { Setb(ToAscii(*s), csbuf); s++; } *cs = csbuf; return T_Cset; } /* * cvint - convert the value represented by dp into an integer and write * the value into the location referenced by i. cvint returns the type or * CvtFail depending on the outcome of the conversion. */int cvint(dp)register dptr dp; { /* * Use cvnum to attempt the conversion into "result". */ switch (cvnum(dp)) { case T_Integer: return T_Integer;#ifdef LargeInts case T_Bignum: /* * Bignum, not in the range of an integer. Fail as we do * for large reals. */ return CvtFail;#endif /* LargeInts */ case T_Real: /* * The value converted into a real number. If it's not in the * range of an integer, fail, otherwise convert the real value * into an integer. */ if (BlkLoc(*dp)->realblk.realval > MaxLong || BlkLoc(*dp)->realblk.realval < MinLong) return CvtFail; dp->dword = D_Integer; IntVal(*dp) = (long)BlkLoc(*dp)->realblk.realval; return T_Integer; default: return CvtFail; } } /* * cvnum - convert the value represented by d into a numeric quantity * in place. The value returned is the type or CvtFail. */int cvnum(dp)register dptr dp; { static char sbuf[MaxCvtLen]; struct descrip cstring; cstring = *dp; /* placed outside "if" to avoid Lattice 3.21 code gen bug */ if (Qual(*dp)) { qtos(&cstring, sbuf); return ston(StrLoc(cstring), dp); } switch (Type(*dp)) { case T_Integer:#ifdef LargeInts case T_Bignum:#endif /* LargeInts */ case T_Real: return Type(*dp); default: /* * Try to convert the value to a string and * then try to convert the string to an integer. */ if (cvstr(dp, sbuf) == CvtFail) return CvtFail; return ston(StrLoc(*dp), dp); } }/* * ston - convert a string to a numeric quantity if possible. */static int ston(s, dp)register char *s;dptr dp; { register int c; int realflag = 0; /* indicates a real number */ char msign = '+'; /* sign of mantissa */ char esign = '+'; /* sign of exponent */ double mantissa = 0; /* scaled mantissa with no fractional part */ long lresult = 0; /* integer result */ int scale = 0; /* number of decimal places to shift mantissa */ int digits = 0; /* total number of digits seen */ int sdigits = 0; /* number of significant digits seen */ int exponent = 0; /* exponent part of real number */ double fiveto; /* holds 5^scale */ double power; /* holds successive squares of 5 to compute fiveto */ int err_no; char *ssave; /* holds original ptr for bigradix */ c = *s++; /* * Skip leading white space. */ while (isspace(c)) c = *s++; /* * Check for sign. */ if (c == '+' || c == '-') { msign = c; c = *s++; } ssave = s - 1; /* set pointer to beginning of digits in case it's needed */ /* * Get integer part of mantissa. */ while (isdigit(c)) { digits++; if (mantissa < Big) { mantissa = mantissa * 10 + (c - '0'); lresult = lresult * 10 + (c - '0'); if (mantissa > 0.0) sdigits++; } else scale++; c = *s++; } /* * Check for based integer. */ if (c == 'r' || c == 'R')#ifdef LargeInts return bigradix(msign, (int)mantissa, s, dp);#else /* LargeInts */ return radix(msign, (int)mantissa, s, dp);#endif /* LargeInts */ /* * Get fractional part of mantissa. */ if (c == '.') { realflag++; c = *s++; while (isdigit(c)) { digits++; if (mantissa < Big) { mantissa = mantissa * 10 + (c - '0'); lresult = lresult * 10 + (c - '0'); scale--; if (mantissa > 0.0) sdigits++; } c = *s++; } } /* * Check that at least one digit has been seen so far. */ if (digits == 0) return CvtFail; /* * Get exponent part. */ if (c == 'e' || c == 'E') { realflag++; c = *s++; if (c == '+' || c == '-') { esign = c; c = *s++; } if (!isdigit(c)) return CvtFail; while (isdigit(c)) { exponent = exponent * 10 + (c - '0'); c = *s++; } scale += (esign == '+') ? exponent : -exponent; } /* * Skip trailing white space. */ while (isspace(c)) c = *s++; /* * Check that entire string has been consumed. */ if (c != '\0') return CvtFail; /* * Test for integer. */ if (!realflag && !scale && mantissa >= MinLong && mantissa <= MaxLong) { dp->dword = D_Integer; IntVal(*dp) = (msign == '+' ? lresult : -lresult); return T_Integer; }#ifdef LargeInts /* * Test for bignum. */ if (!realflag) return bigradix(msign, 10, ssave, dp);#endif /* LargeInts */ if (!realflag) return CvtFail; /* don't promote to real if integer format */ /* * Rough tests for overflow and underflow. */ if (sdigits + scale > LogHuge) return CvtFail; if (sdigits + scale < -LogHuge) { makereal(0.0, dp); return T_Real; } /* * Put the number together by multiplying the mantissa by 5^scale and * then using ldexp() to multiply by 2^scale. */ exponent = (scale > 0)? scale : -scale; fiveto = 1.0; power = 5.0; for (;;) { if (exponent & 01) fiveto *= power; exponent >>= 1; if (exponent == 0) break; power *= power; } if (scale > 0) mantissa *= fiveto; else mantissa /= fiveto; err_no = 0; mantissa = ldexp(mantissa, scale); if (err_no > 0 && mantissa > 0) /* * ldexp caused overflow. */ return CvtFail; if (msign == '-') mantissa = -mantissa; makereal(mantissa, dp); return T_Real; }#ifndef LargeInts/* * radix - convert string s in radix r into an integer in *dp. sign * will be either '+' or '-'. */static int radix(sign, r, s, dp)int sign;register int r;register char *s;dptr dp; { register int c; long num; if (r < 2 || r > 36) return CvtFail; c = *s++; num = 0L; while (isalnum(c)) { c = tonum(c); if (c >= r) return CvtFail; num = num * r + c; c = *s++; } while (isspace(c)) c = *s++; if (c != '\0') return CvtFail; dp->dword = D_Integer; dp->vword.integr = (sign == '+' ? num : -num); return T_Integer; }#endif /* LargeInts */ /* * cvpos - convert position to strictly positive position * given length. */word cvpos(pos, len)long pos;register long len; { register word p; /* * Make sure the position is in the range of an int. (?) */ if ((long)(p = pos) != pos) return CvtFail; /* * Make sure the position is within range. */ if (p < -len || p > len + 1) return CvtFail; /* * If the position is greater than zero, just return it. Otherwise, * convert the zero/negative position. */ if (pos > 0) return p; return (len + p + 1); } /* * cvreal - convert to real in place. */int cvreal(dp)register dptr dp; { /* * Use cvnum to classify the value. Cast integers into reals and * fail if the value is non-numeric. */ switch (cvnum(dp)) { case T_Integer: makereal((double)IntVal(*dp), dp); return T_Real;#ifdef LargeInts case T_Bignum: makereal(bigtoreal(dp), dp); return T_Real;#endif /* LargeInts */ case T_Real: return T_Real; default: return CvtFail; } } /* * cvstr(dp,s) - convert dp (in place) into a string, using s as buffer * if necessary. cvstr returns CvtFail if the conversion fails, Cvt if dp * wasn't a string but was converted into one, and NoCvt if dp was already * a string. When a string conversion takes place, sbuf gets the * resulting string. */int cvstr(dp, sbuf)register dptr dp;char *sbuf; { double rres; if (Qual(*dp)) return NoCvt; /* It is already a string */ switch (Type(*dp)) { /* * For types that can be converted into strings, call the * appropriate conversion routine and return its result. * Note that the conversion routines change the descriptor * pointed to by dp. */ case T_Integer: return itos((long)IntVal(*dp), dp, sbuf);#ifdef LargeInts case T_Bignum: return bigtos(dp, dp);#endif /* LargeInts */ case T_Real: GetReal(dp,rres); return rtos(rres, dp, sbuf); case T_Cset: return cstos(BlkLoc(*dp)->cset.bits, dp, sbuf); default: /* * The value cannot be converted to a string. */ return CvtFail; } } /* * itos - convert the integer num into a string using s as a buffer and * making q a descriptor for the resulting string. */static int itos(num, dp, s)long num;dptr dp;char *s; { register char *p; long ival; static char *maxneg = MaxNegInt; p = s + MaxCvtLen - 1; ival = num; *p = '\0'; if (num >= 0L) do { *--p = ival % 10L + '0'; ival /= 10L; } while (ival != 0L); else { if (ival == -ival) { /* max negative value */ p -= strlen (maxneg); sprintf (p, "%s", maxneg); } else { ival = -ival; do { *--p = '0' + (ival % 10L); ival /= 10L; } while (ival != 0L); *--p = '-'; } } StrLen(*dp) = s + MaxCvtLen - 1 - p; StrLoc(*dp) = p; return Cvt; }/* * rtos - convert the real number n into a string using s as a buffer and * making a descriptor for the resulting string. */int rtos(n, dp, s)double n;dptr dp;char *s; { s++; /* leave room for leading zero *//* * The following code is operating-system dependent [@rconv.01]. Convert real * number to string. * * If IconGcvt is defined, icon_gcvt() is actually called, due to a #define * in config.h. */#if PORT gcvt(n, Precision, s);Deliberate Syntax Error#endif /* PORT */#if AMIGA || ATARI_ST || MSDOS || UNIX || VMS gcvt(n, Precision, s);#endif /* AMIGA || ATARI_ST || ... */#if VM || MVS#if SASC sprintf(s,"%.*g", Precision, n); { char *ep = strstr(s, "e+"); if (ep) memmove(ep+1, ep+2, strlen(ep+2)+1); }#else /* SASC */ gcvt(n, Precision, s);#endif /* SASC */#endif /* MVS || VM */#if HIGHC_386 sprintf(s,"%.*g", Precision, n);#endif /* HIGHC_386 */#if MACINTOSH sprintf(s,"%.20g",n);#endif /* MACINTOSH *//* * End of operating-system specific code. */ /* * Now clean up possible messes. */ while (*s == ' ') /* delete leading blanks */ s++; if (*s == '.') { /* prefix 0 t0 to initial period */ s--; *s = '0'; } else if (strcmp(s, "-0.0") == 0) /* negative zero */ s++; else if (!index(s, '.') && !index(s,'e') && !index(s,'E')) strcat(s, ".0"); /* if no decimal point or exp. */ if (s[strlen(s) - 1] == '.') /* if decimal point is at the end ... */ strcat(s, "0"); StrLen(*dp) = strlen(s); StrLoc(*dp) = s; return Cvt; } /* * cstos - convert the cset bit array pointed at by cs into a string using * s as a buffer and making a descriptor for the resulting string. */static int cstos(cs, dp, s)int *cs;dptr dp;char *s; { register unsigned int w; register int j, i; register char *p; p = s; for (i = 0; i < CsetSize; i++) { if (cs[i]) for (j=i*IntBits, w=cs[i]; w; j++, w >>= 1) if (w & 01) *p++ = FromAscii((char)j); } *p = '\0'; StrLen(*dp) = p - s; StrLoc(*dp) = s; return Cvt; } /* * makereal(r, dp) - make a real number descriptor and associated block * for r and place it in *dp. */int makereal(r, dp)double r;register dptr dp; { if (blkreq((uword)sizeof(struct b_real)) == Error) return Error; dp->dword = D_Real; BlkLoc(*dp) = (union block *)alcreal(r); return Success; } /* * mksubs - form a substring. var is a descriptor for the string from * which the substring is to be formed. var may be a variable. val * is a dereferenced version of var. The descriptor for the resulting * substring is placed in *result. The substring starts at position * i and extends for j characters. */novalue mksubs(var, val, i, j, result)register dptr var, val, result;word i, j; { if (!Var(*var)) { /* * var isn't a variable, just form a descriptor that points into * the string named by val. */ StrLen(*result) = j; StrLoc(*result) = StrLoc(*val) + i - 1; return; } if ((var)->dword == D_Tvsubs) { /* * If var is a substring trapped variable, * adjust the position and make var the substrung string. */ i += BlkLoc(*var)->tvsubs.sspos - 1; var = &BlkLoc(*var)->tvsubs.ssvar; } /* * Make a substring trapped variable by passing the buck to alcsubs. */ result->dword = D_Tvsubs; BlkLoc(*result) = (union block *) alcsubs(j, i, var); return; } /* * strprc - Convert the qualified string named by *dp into a procedure * descriptor if possible. n is the number of arguments that the desired * procedure has. n is only used when the name of the procedure is * non-alphabetic (hence, an operator). * */int strprc(dp, n)dptr dp;word n; {#ifndef StrInvoke return CvtFail;#else /* StrInvoke */ dptr np, gp; struct pstrnm *p; char *s; int i; word ns; /* * Look in global name list first. */ np = gnames; gp = globals; while (gp < eglobals) { if (!lexcmp(np++,dp)) if (BlkLoc(*gp)->proc.title == T_Proc) { StrLen(*dp) = D_Proc; /* really type field */ BlkLoc(*dp) = BlkLoc(*gp); return T_Proc; } gp++; }/* * The name is not a global, see if it is a function or an operator. */ s = StrLoc(*dp); if (StrLen(*dp) > MaxCvtLen) /* can't be that big */ return CvtFail; i = (int)StrLen(*dp); for (p = pntab; p->pstrep; p++) /* * Compare the desired name with each standard procedure/operator * name. */ if (strlen(p->pstrep) == i && strncmp(s,p->pstrep,i) == 0) { if (isalpha(*s)) { /* * The names are the same and s starts with an alphabetic, * so it's the one being looked for; return it. */ StrLen(*dp) = D_Proc; BlkLoc(*dp) = (union block *) p->pblock; return T_Proc; } if ((ns = p->pblock->nstatic) < 0) ns = -ns; else ns = abs((in
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:rconv.
+++++ Continued from previous card +++++
t)p->pblock->nparam); if (n == ns) { StrLen(*dp) = D_Proc; /* really type field */ BlkLoc(*dp) = (union block *)p->pblock; return T_Proc; } } return CvtFail;#endif /* StrInvoke */ } :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:rdebug.c
/* * rdebug.c - breakpoint, variable, ttrace, xtrace. */#include <math.h>#include "::h:config.h"#include "::h:rt.h"#include "rproto.h"#include "::h:opdefs.h"#ifdef TraceBackextern struct b_list list_tmp; /* argument of Op_Apply */extern struct b_proc *opblks[];extern word lastop; /* last op-code */extern dptr xargp;extern word xnargs; /* number of arguments */extern dptr fnames;#endif /* TraceBack */ #ifdef TraceBack/* * ttrace - show offending expression. */novalue ttrace() { struct b_proc *bp; word nargs; fprintf(stderr, " "); switch ((int)lastop) { case Op_Invoke: bp = (struct b_proc *)BlkLoc(*xargp); nargs = xnargs; if (xargp[0].dword == D_Proc) putstr(stderr, &(bp->pname)); else outimage(stderr, xargp, 0); putc('(', stderr); while (nargs--) { outimage(stderr, ++xargp, 0); if (nargs) putc(',', stderr); } putc(')', stderr); break; case Op_Toby: putc('{', stderr); outimage(stderr, ++xargp, 0); fprintf(stderr, " to "); outimage(stderr, ++xargp, 0); fprintf(stderr, " by "); outimage(stderr, ++xargp, 0); putc('}', stderr); break; case Op_Subsc: putc('{', stderr); outimage(stderr, ++xargp, 0); putc('[', stderr); outimage(stderr, ++xargp, 0); putc(']', stderr); putc('}', stderr); break; case Op_Sect: putc('{', stderr); outimage(stderr, ++xargp, 0); putc('[', stderr); outimage(stderr, ++xargp, 0); putc(':', stderr); outimage(stderr, ++xargp, 0); putc(']', stderr); putc('}', stderr); break; case Op_Bscan: putc('{', stderr); outimage(stderr, xargp, 0); fputs(" ? ..}", stderr); break; case Op_Coact: putc('{', stderr); outimage(stderr, ++xargp, 0); fprintf(stderr, " @ "); outimage(stderr, ++xargp, 0); putc('}', stderr); break; case Op_Apply: outimage(stderr, xargp++, 0); fprintf(stderr," ! "); outimage(stderr, (dptr)&list_tmp, 0); break; case Op_Create: fprintf(stderr,"{create ..}"); break; case Op_Field: putc('{', stderr); outimage(stderr, ++xargp, 0); fprintf(stderr, " . "); fprintf(stderr, "%s", StrLoc(fnames[IntVal(*++xargp)])); putc('}', stderr); break; case Op_Limit: fprintf(stderr, "limit counter: "); outimage(stderr, xargp, 0); break; case Op_Llist: fprintf(stderr,"[ ... ]"); break; default: bp = opblks[lastop]; nargs = abs((int)bp->nparam); putc('{', stderr); if (lastop == Op_Bang || lastop == Op_Random) goto oneop; if (abs((int)bp->nparam) >= 2) { outimage(stderr, ++xargp, 0); putc(' ', stderr); putstr(stderr, &(bp->pname)); putc(' ', stderr); } elseoneop: putstr(stderr, &(bp->pname)); outimage(stderr, ++xargp, 0); putc('}', stderr); } if (ipc.opnd != NULL) fprintf(stderr, " from line %d in %s", findline(ipc.opnd), findfile(ipc.opnd)); putc('\n', stderr); fflush(stderr); } /* * xtrace - procedure *bp is being called with nargs arguments, the first * of which is at arg; produce a trace message. */novalue xtrace(bp, nargs, arg, pline, pfile)struct b_proc *bp;word nargs;dptr arg;int pline;char *pfile; { fprintf(stderr, " "); if (bp == NULL) fprintf(stderr, "????"); else { if (arg[0].dword == D_Proc) putstr(stderr, &(bp->pname)); else outimage(stderr, arg, 0); arg++; putc('(', stderr); while (nargs--) { outimage(stderr, arg++, 0); if (nargs) putc(',', stderr); } putc(')', stderr); } if (pline != 0) fprintf(stderr, " from line %d in %s", pline, pfile); putc('\n', stderr); fflush(stderr); }#endif /* TraceBack */ /* * Service routine to display variables in given number of * procedure calls to file f. */novalue xdisp(fp,dp,count,f) int count; FILE *f; struct pf_marker *fp; register dptr dp; { register dptr np; register int n; struct b_proc *bp; extern dptr globals, eglobals; extern dptr gnames; extern dptr statics; while (count--) { /* go back through 'count' frames */ bp = (struct b_proc *)BlkLoc(*dp); /* get address of procedure block */ /* * Print procedure name. */ putstr(f, &(bp->pname)); fprintf(f, " local identifiers:\n"); /* * Print arguments. */ np = bp->lnames; for (n = abs(bp->nparam); n > 0; n--) { fprintf(f, " "); putstr(f, np); fprintf(f, " = "); outimage(f, ++dp, 0); putc('\n', f); np++; } /* * Print locals. */ dp = &fp->pf_locals[0]; for (n = (int)bp->ndynam; n > 0; n--) { fprintf(f, " "); putstr(f, np); fprintf(f, " = "); outimage(f, dp++, 0); putc('\n', f); np++; } /* * Print statics. */ dp = &statics[bp->fstatic]; for (n = (int)bp->nstatic; n > 0; n--) { fprintf(f, " "); putstr(f, np); fprintf(f, " = "); outimage(f, dp++, 0); putc('\n', f); np++; } dp = fp->pf_argp; fp = fp->pf_pfp; } /* * Print globals. */ fprintf(f, "\nglobal identifiers:\n"); dp = globals; np = gnames; while (dp < eglobals) { fprintf(f, " "); putstr(f, np); fprintf(f, " = "); outimage(f, dp++, 0); putc('\n', f); np++; } fflush(f); } :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:rdefault.c
/* * File: rdefault.c * Contents: defcset, deffile, defint, defshort, defstr */#include "::h:config.h"#include "::h:rt.h"#include "rproto.h"/* * defcset(dp,cp,buf,def) - if dp is null, default to def; * otherwise, convert to cset or die trying. */int defcset(dp, cp, buf, def)dptr dp;int **cp;int *buf, *def; { if (ChkNull(*dp)) { *cp = def; return Defaulted; } if (cvcset(dp, cp, buf) == CvtFail) RetError(104, *dp); return Success; } /* * deffile - if dp is null, default to def; otherwise, make sure it's a file. */int deffile(dp, def)dptr dp, def; { if (ChkNull(*dp)) { *dp = *def; return Defaulted; } if (dp->dword != D_File) RetError(105, *dp); return Success; } /* * defint - if dp is null, default to def; otherwise, convert to integer. * Note that *lp gets the value. */int defint(dp, lp, def)dptr dp;long *lp;word def; { if (ChkNull(*dp)) { *lp = (long)def; return Defaulted; } if (cvint(dp) == CvtFail) RetError(101, *dp); *lp = IntVal(*dp); return Success; } /* * defshort - if dp is null, default to def; otherwise, convertt * integer. The result is an integer value in *dp. */int defshort(dp, def)dptr dp;int def; { if (ChkNull(*dp)) { MakeInt((int)def, dp); return Defaulted; } switch (cvint(dp)) { case T_Integer: return Success; default: RetError(101, *dp); } } /* * defstr - if dp is null, default to def; otherwise, convert to string. * *dp gets a descriptor for the resulting string. buf is used as * a scratch buffer for the conversion (if necessary). */int defstr(dp, buf, def)dptr dp;char *buf;dptr def; { int retcode; if (ChkNull(*dp)) { *dp = *def; return Defaulted; } retcode = cvstr(dp, buf); if (retcode == CvtFail) { RetError(103, *dp); } else return retcode; } :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:rdoasgn.c
/* * File: rdoasgn.c * Contents: doasgn.c */#include "::h:config.h"#include "::h:rt.h"#include "rproto.h"/* * doasgn - assign value of dp2 to variable dp1. * Does the work for asgn, swap, rasgn, and rswap. */int doasgn(dp1, dp2)dptr dp1, dp2; { register word i1, i2; register union block *bp; register struct b_table *tp; register uword hn; int (*putf)(); int ret_code; union block *hook, **slot; char sbuf1[MaxCvtLen]; tended[1] = *dp1; tended[2] = *dp2; ntended = 2;assign: if (!Tvar(tended[1])) *(dptr)((word *)VarLoc(tended[1]) + Offset(tended[1])) = tended[2]; else switch (Type(tended[1])) { case T_Tvsubs: /* * An assignment is being made to a substring trapped * variable. The tended descriptors are used as * follows: * * tended[1] - the substring trapped variable * tended[2] - the value to assign * tended[3] - the string containing the substring * tended[4] - the substring * tended[5] - the result string */ /* * Be sure that the value to be assigned is a string. */ ntended = 5; if (DeRef(tended[2]) == Error) { ntended = 0; return Error; } if (cvstr(&tended[2], sbuf1) == CvtFail) { ntended = 0; RetError(103, tended[2]); } /* * Be sure that the variable in the trapped variable points * to a string. */ tended[3] = BlkLoc(tended[1])->tvsubs.ssvar; if (DeRef(tended[3]) == Error) { ntended = 0; return Error; } if (!Qual(tended[3])) { ntended = 0; RetError(103, tended[3]); } if (strreq(StrLen(tended[3]) + StrLen(tended[2])) == Error) return Error; /* * Get a pointer to the substring trapped-variable block and * make i1 a C-style index to the character that begins the * substring. */ bp = BlkLoc(tended[1]); i1 = bp->tvsubs.sspos - 1; /* * Make tended[4] a descriptor for the substring. */ StrLen(tended[4]) = bp->tvsubs.sslen; StrLoc(tended[4]) = StrLoc(tended[3]) + i1; /* * Make i2 a C-style index to the character after the * substring. If i2 is greater than the length of the * substring, it is an error because the string being * assigned will not fit. */ i2 = i1 + StrLen(tended[4]); if (i2 > StrLen(tended[3])) { ntended = 0; RetError(-205, nulldesc); } /* * Form the result string. First, copy the portion of the * substring string to the left of the substring into the * string space. */ StrLoc(tended[5]) = alcstr(StrLoc(tended[3]), i1); /* * Copy the string to be assigned into the string space, * effectively concatenating it. */ alcstr(StrLoc(tended[2]), StrLen(tended[2])); /* * Copy the portion of the substring to the right of * the substring into the string space, completing the * result. */ alcstr(StrLoc(tended[3]) + i2, StrLen(tended[3]) - i2); /* * Calculate the length of the new string. */ StrLen(tended[5]) = StrLen(tended[3]) - StrLen(tended[4]) + StrLen(tended[2]); bp->tvsubs.sslen = StrLen(tended[2]); tended[1] = bp->tvsubs.ssvar; tended[2] = tended[5]; /* * Everything is set up for the actual assignment. Go * back to the beginning of the routine to do it. */ goto assign; case T_Tvtbl: /* * * The tended descriptors are used as follows: * * tended[1] - the table element trapped variable * tended[2] - the value to be assigned * tended[3] - subscripting value */ /* * Point bp to the trapped-variable block, point tended[3] * to the subscripting value, and point tp to the table- * header block. */ ntended = 3; bp = BlkLoc(tended[1]); if (bp->tvtbl.title == T_Telem) { /* * The trapped-variable block already has been * converted to a table-element block. Just assign * to it and return. */ bp->telem.tval = tended[2]; ntended = 0; return Success; } tended[3] = bp->tvtbl.tref; tp = (struct b_table *)bp->tvtbl.clink; /* * Get the hash number for the subscripting value and * locate the chain that contains the element to which * assignment is to be made. */ hn = bp->tvtbl.hashnum; slot = hchain((union block *)tp, hn); bp = *slot; /* * Traverse the chain to see if the value is already in the * table. If it is there, assign to it and return. */ hook = bp; while (bp != NULL && bp->telem.hashnum <= hn) { if (bp->telem.hashnum == hn && equiv(&bp->telem.tref, &tended[3])) { bp->telem.tval = tended[2]; ntended = 0; return Success; } hook = bp; bp = bp->telem.clink; } /* * The value being assigned is new. Increment the table * size, convert the table-element trapped-variable block * to a table-element block, and link it into the chain. */ tp->size++; if (hook == bp) { /* it goes at front of chain */ bp = BlkLoc(tended[1]); bp->telem.clink = *slot; *slot = bp; } else { /* it follows hook */ bp = BlkLoc(tended[1]); bp->telem.clink = hook->telem.clink; hook->telem.clink = bp; } bp->tvtbl.title = T_Telem; bp->telem.tval = tended[2]; tended[1].dword = D_Telem; MMShow(&tended[1], "r"); if (TooCrowded(tp)) { tended[1].dword = D_Table; BlkLoc(tended[1]) = (union block *)tp; hgrow(&tended[1]); } ntended = 0; return Success; case T_Tvkywd: ntended = 2; putf = BlkLoc(tended[1])->tvkywd.putval; ret_code = (*putf)(&tended[2], BlkLoc(tended[1])); ntended = 0; return ret_code; default: syserr("doasgn: illegal trapped variable"); } ntended = 0; return Success; } :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:rlargint.c
#include <math.h>#include "::h:config.h"#include "::h:rt.h"#include "rproto.h"#include <ctype.h>#ifdef LargeIntsextern int over_flow;/* * Conventions: * * Bignums entering this module and leaving it are too large to * be represented with T_Integer. So, externally, a given value * is always T_Integer or always T_Bignum. * * Routines outside this module operate on bignums by calling * a routine like * * bigadd(da, db, dx) * * where da, db, and dx are pointers to tended descriptors. * For the common case where one argument is a T_Integer, these * call routines like * * bigaddi(da, IntVal(*db), dx). * * The bigxxxi routines can convert an integer to bignum form; * they use itobig. * * The routines that actually do the work take (length, address) * pairs specifying unsigned base-B digit strings. The sign handling * is done in the bigxxx routines. */ /* * Type for doing arithmetic on (2 * NB)-bit nonnegative numbers. * Normally unsigned but may be signed (with NB reduced appropriately) * if unsigned arithmetic is slow. *//* The bignum radix, B */#define B ((word)1 << NB)/* Bignum digits in a word */#define WORDLEN (WordBits / NB + (WordBits % NB != 0))/* size of a bignum block that will hold an integer */#define INTBIGBLK sizeof(struct b_bignum) + sizeof(DIGIT) * WORDLEN/* lo(uword d) : the low digit of a uword hi(uword d) : the rest, d is unsigned signed_hi(uword d) : the rest, d is signed dbl(DIGIT a, DIGIT b) : the two-digit uword [a,b] */#define lo(d) ((d) & (B - 1))#define hi(d) ((uword)(d) >> NB)#define dbl(a,b) (((uword)(a) << NB) + (b))#if ((-1) >> 1) < 0#define signed_hi(d) ((word)(d) >> NB)#else#define signbit ((uword)1 << (WordBits - NB - 1))#define signed_hi(d) ((word)((((uword)(d) >> NB) ^ signbit) - signbit))#endif/* BigNum(dptr dp) : the struct b_bignum pointed to by dp */#define BigNum(dp) ((struct b_bignum *)&BlkLoc(*dp)->bignumblk)/* LEN(struct b_bignum *b) : number of significant digits */#define LEN(b) ((b)->lsd - (b)->msd + 1)/* DIG(struct b_bignum *b, word i): pointer to ith most significant digit */#define DIG(b,i) (&(b)->digits[(b)->msd+(i)])/* ceil, ln: ceil may be 1 too high in case ln is inaccurate */#undef ceil#define ceil(x) ((word)((x) + 1.01))#define ln(n) (log((double)n))/* determine the number of words needed for a bignum block with n digits */#define BigNeed(n) ( ((sizeof(struct b_bignum) + ((n) - 1) * sizeof(DIGIT)) \ + WordSize - 1) & -WordSize )/* copied from rconv.c */#if !EBCDIC#define tonum(c) (isdigit(c) ? (c)-'0' : 10+(((c)|(040))-'a'))#else #define tonum(c) index("0123456789abcdefghijklmnopqrstuvwsyz", tolower(c))#endif/* copied from oref.c */#define RandVal (RanScale*(k_random=(RandA*k_random+RandC)&MaxLong))hidden int mkdesc Params((struct b_bignum *x, dptr dx));hidden novalue itobig Params((word i, struct b_bignum *x, dptr dx));hidden novalue decout Params((FILE *f, DIGIT *n, word l));hidden int bigaddi Params((dptr da, word i, dptr dx));hidden int bigsubi Params((dptr da, word i, dptr dx));hidden int bigmuli Params((dptr da, word i, dptr dx));hidden int bigdivi Params((dptr da, word i, dptr dx));hidden int bigmodi Params((dptr da, word i, dptr dx));hidden int bigpowi Params((dptr da, word i, dptr dx));hidden int bigpowii Params((word a, word i, dptr dx));hidden word bigcmpi Params((dptr da, word i));hidden DIGIT add1 Params((DIGIT *u, DIGIT *v, DIGIT *w, word n));hidden word sub1 Params((DIGIT *u, DIGIT *v, DIGIT *w, word n));hidden novalue mul1 Params((DIGIT *u, DIGIT *v, DIGIT *w, word n, word m));hidden novalue div1 Params((DIGIT *a, DIGIT *b, DIGIT *q, DIGIT *r, word m, word n));hidden novalue compl1 Params((DIGIT *u, DIGIT *w, word n));hidden word cmp1 Params((DIGIT *u, DIGIT *v, word n));hidden DIGIT addi1 Params((DIGIT *u, word k, DIGIT *w, word n));hidden novalue subi1 Params((DIGIT *u, word k, DIGIT *w, word n));hidden DIGIT muli1 Params((DIGIT *u, word k, int c, DIGIT *w, word n));hidden DIGIT divi1 Params((DIGIT *u, word k, DIGIT *w, word n));hidden DIGIT shifti1 Params((DIGIT *u, word k, DIGIT c, DIGIT *w, word n));hidden word cmpi1 Params((DIGIT *u, word k, word n));hidden novalue bdzero Params((DIGIT *dest, word l));hidden novalue bdcopy Params((DIGIT *src, DIGIT *dest, word l)); /* * mkdesc -- put value into a descriptor */static int mkdesc(x, dx)struct b_bignum *x;dptr dx;{ word xlen, cmp; static DIGIT maxword[WORDLEN] = { 1 << ((WordBits - 1) % NB) }; /* suppress leading zero digits */ while (x->msd != x->lsd && *DIG(x,0) == 0) x->msd++; /* put it into a word if it fits, otherwise return the bignum */ xlen = LEN(x); if (xlen < WORDLEN || (xlen == WORDLEN && ((cmp = cmp1(DIG(x,0), maxword, WORDLEN)) < 0 || (cmp == (word)0 && x->sign)))) { word val = -(word)*DIG(x,0); word i; for (i = x->msd; ++i <= x->lsd; ) val = (val << NB) - x->digits[i]; if (!x->sign) val = -val; dx->dword = D_Integer; IntVal(*dx) = val; } else { dx->dword = D_Bignum; BlkLoc(*dx) = (union block *)x; } return Success;}/* * i -> big */static novalue itobig(i, x, dx)word i;struct b_bignum *x;dptr dx;{ x->lsd = WORDLEN - 1; x->msd = WORDLEN; x->sign = 0; if (i == 0) { x->msd--; *DIG(x,0) = 0; } else if (i < 0) { word d = lo(i); if (d != 0) { d = B - d; i += B; } i = - signed_hi(i); x->msd--; *DIG(x,0) = d; x->sign = 1; } while (i != 0) { x->msd--; *DIG(x,0) = lo(i); i = hi(i); } dx->dword = D_Bignum; BlkLoc(*dx) = (union block *)x;} /* * string -> bignum */word bigradix(sign, r, s, dx)int sign; /* '-' or not */int r; /* radix 2 .. 36 */char *s; /* input string */dptr dx; /* output T_Integer or T_Bignum */{ struct b_bignum *b; DIGIT *bd; word len; int c; if (r == 0) return CvtFail; len = ceil(strlen(s) * ln(r) / ln(B)); if (blkreq(BigNeed(len)) == Error) return CvtFail; b = alcbignum(len); bd = DIG(b,0); bdzero(bd, len); if (r < 2 || r > 36) return CvtFail; for (c = *s++; isalnum(c); c = *s++) { c = tonum(c); if (c >= r) return CvtFail; muli1(bd, (word)r, c, bd, len); } while (isspace(c)) c = *s++; if (c != '\0') return CvtFail; if (sign == '-') b->sign = 1; /* put value into dx and return the type */ (void)mkdesc(b, dx); return Type(*dx);}/* * bignum -> real */double bigtoreal(da)dptr da;{ word i; double r = 0; struct b_bignum *b = &BlkLoc(*da)->bignumblk; for (i = b->msd; i <= b->lsd; i++) r = r * B + b->digits[i]; return (b->sign ? -r : r);}/* * real -> bignum */int realtobig(da, dx)dptr da, dx;{ double x = BlkLoc(*da)->realblk.realval; struct b_bignum *b; word i, blen; word d; if (x > 0.9999 * MinLong && x < 0.9999 * MaxLong) { MakeInt((word)x, dx); return Success; /* got lucky; a simple integer suffices */ } x = x > 0 ? x : -x; blen = ln(x) / ln(B) + 0.99; for (i = 0; i < blen; i++) x /= B; if (x >= 1.0) { x /= B; blen += 1; } if (blkreq(BigNeed(blen)) == Error) return Error; b = alcbignum(blen); for (i = 0; i < blen; i++) { d = (x *= B); *DIG(b,i) = d; x -= d; } b->sign = x < 0; return mkdesc(b, dx);}/* * bignum -> string */int bigtos(da, dx)dptr da, dx;{ struct b_bignum *a, *temp; word alen = LEN(BigNum(da)); word slen = ceil(alen * ln(B) / ln(10)); char *p, *q; if (strreq(slen) == Error || blkreq(BigNeed(alen)) == Error) return CvtFail; a = BigNum(da); temp = alcbignum(alen); if (a->sign) slen++; q = alcstr("",slen); bdcopy(DIG(a,0), DIG(temp,0), alen); p = q += slen; while (cmpi1(DIG(temp,0), (word)0, alen)) *--p = '0' + divi1(DIG(temp,0), (word)10, DIG(temp,0), alen); if (a->sign) *--p = '-'; StrLen(*dx) = q - p; StrLoc(*dx) = p; return Cvt;}/* * bignum -> file */novalue bigprint(f, da)FILE *f;dptr da;{ struct b_bignum *a, *temp; word alen = LEN(BigNum(da)); word slen, dlen; slen = (BlkLoc(*da)->bignumblk.lsd - BlkLoc(*da)->bignumblk.msd + 1); dlen = slen * NB * 0.3010299956639812; /* 1 / log2(10) */ if (dlen > MaxDigits) { fprintf(f, "integer(~%ld)",dlen - 2); /* center estimate */ return; } if (blkreq(BigNeed(alen)) == Error) { fatalerr(0, NULL); /* not worth passing this one back */ } temp = alcbignum(alen); a = BigNum(da); bdcopy(DIG(a,0), DIG(temp,0), alen); if (a->sign) putc('-', f); decout(f, DIG(temp,0), alen);}static novalue decout(f, n, l)FILE *f;DIGIT *n;word l;{ word i = divi1(n, (word)10, n, l); if (cmpi1(n, (word)0, l)) decout(f, n, l); putc('0' + i, f);}/* * da -> dx */int cpbignum(da, dx)dptr da, dx;{ struct b_bignum *a; word alen = LEN(BigNum(da)); struct b_bignum *x; if (blkreq(BigNeed(alen)) == Error) return Error; x = alcbignum(alen); a = BigNum(da); bdcopy(DIG(a,0), DIG(x,0), alen); x->sign = a->sign; return mkdesc(x, dx);} /* * da + db -> dx */int bigadd(da, db, dx)dptr da, db;dptr dx;{ struct b_bignum *x, *a, *b; word alen, blen; word c; if (Type(*da) == T_Bignum && Type(*db) == T_Bignum) { alen = LEN(BigNum(da)); blen = LEN(BigNum(db)); if (blkreq(BigNeed(alen > blen ? alen + 1 : blen + 1)) == Error) return Error; a = BigNum(da); b = BigNum(db); if (a->sign == b->sign) { if (alen > blen) { x = alcbignum(alen + 1); c = add1(DIG(a,alen-blen), DIG(b,0), DIG(x,alen-blen+1), blen); *DIG(x,0) = addi1(DIG(a,0), c, DIG(x,1), alen-blen); } else if (alen == blen) { x = alcbignum(alen + 1); *DIG(x,0) = add1(DIG(a,0), DIG(b,0), DIG(x,1), alen); } else { x = alcbignum(blen + 1); c = add1(DIG(b,blen-alen), DIG(a,0), DIG(x,blen-alen+1), alen); *DIG(x,0) = addi1(DIG(b,0), c, DIG(x,1), blen-alen); } x->sign = a->sign; } else { if (alen > blen) { x = alcbignum(alen); c = sub1(DIG(a,alen-blen), DIG(b,0), DIG(x,alen-blen), blen); subi1(DIG(a,0), -c, DIG(x,0), alen-blen); x->sign = a->sign; } else if (alen == blen) { x = alcbignum(alen); if (cmp1(DIG(a,0), DIG(b,0), alen) > 0) { (void)sub1(DIG(a,0), DIG(b,0), DIG(x,0), alen); x->sign = a->sign; } else { (void)sub1(DIG(b,0), DIG(a,0), DIG(x,0), alen); x->sign = b->sign; } } else { x = alcbignum(blen); c = sub1(DIG(b,blen-alen), DIG(a,0), DIG(x,blen-alen), alen); subi1(DIG(b,0), -c, DIG(x,0), blen-alen); x->sign = b->sign; } } return mkdesc(x, dx); } else if (Type(*da) == T_Bignum) /* bignum + integer */ return bigaddi(da, IntVal(*db), dx); else if (Type(*db) == T_Bignum) /* integer + bignum */ return bigaddi(db, IntVal(*da), dx); else { /* integer + integer */ struct descrip td; char tdigits[INTBIGBLK]; itobig(IntVal(*da), (struct b_bignum *)tdigits, &td); return bigaddi(&td, IntVal(*db), dx); }}/* * da - db -> dx */ int bigsub(da, db, dx)dptr da, db, dx;{ struct descrip td; char tdigits[INTBIGBLK]; struct b_bignum *a, *b, *x; word alen, blen; word c; if (Type(*da) == T_Bignum && Type(*db) == T_Bignum) { alen = LEN(BigNum(da)); blen = LEN(BigNum(db)); if (blkreq(BigNeed(alen > blen ? alen + 1 : blen + 1)) == Error) return Error; a = BigNum(da); b = BigNum(db); if (a->sign != b->sign) { if (alen > blen) { x = alcbignum(alen + 1); c = add1(DIG(a,alen-blen), DIG(b,0), DIG(x,alen-blen+1), blen); *DIG(x,0) = addi1(DIG(a,0), c, DIG(x,1), alen-blen); } else if (alen == blen) { x = alcbignum(alen + 1); *DIG(x,0) = add1(DIG(a,0), DIG(b,0), DIG(x,1), alen); } else { x = alcbignum(blen + 1); c = add1(DIG(b,blen-alen), DIG(a,0), DIG(x,blen-alen+1), alen); *DIG(x,0) = addi1(DIG(b,0), c, DIG(x,1), blen-alen); } x->sign = a->sign; } else { if (alen > blen) { x = alcbignum(alen); c = sub1(DIG(a,alen-blen), DIG(b,0), DIG(x,alen-blen), blen); subi1(DIG(a,0), -c, DIG(x,0), alen-blen); x->sign = a->sign; } else if (alen == blen) { x = alcbignum(alen); if (cmp1(DIG(a,0), DIG(b,0), alen) > 0) { (void)sub1(DIG(a,0), DIG(b,0), DIG(x,0), alen); x->sign = a->sign; } else { (void)sub1(DIG(b,0), DIG(a,0), DIG(x,0), alen); x->sign = 1 ^ b->sign; } } else { x = alcbignum(blen); c = sub1(DIG(b,blen-alen), DIG(a,0), DIG(x,blen-alen), alen); subi1(DIG(b,0), -c, DIG(x,0), blen-alen); x->sign = 1 ^ b->sign; } } return mkdesc(x, dx); } else if (Type(*da) == T_Bignum) /* bignum - integer */ return bigsubi(da, IntVal(*db), dx); else if (Type(*db) == T_Bignum) { /* integer - bignum */ itobig(IntVal(*da), (struct b_bignum *)tdigits, &td); alen = LEN(BigNum(&td)); blen = LEN(BigNum(db)); if (blkreq(BigNeed(alen > blen ? alen + 1 : blen + 1)) == Error) return Error; a = BigNum(&td); b = BigNum(db); if (a->sign != b->sign) { if (alen == blen) { x = alcbignum(alen + 1); *DIG(x,0) = add1(DIG(a,0), DIG(b,0), DIG(x,1), alen); } else { x = alcbignum(blen + 1); c = add1(DIG(b,blen-alen), DIG(a,0), DIG(x,blen-alen+1), alen); *DIG(x,0) = addi1(DIG(b,0), c, DIG(x,1), blen-alen); } x->sign = a->sign; } else { if (alen == blen) { x = alcbignum(alen); if (cmp1(DIG(a,0), DIG(b,0), alen) > 0) { (void)sub1(DIG(a,0), DIG(b,0), DIG(x,0), alen); x->sign = a->sign; } else { (void)sub1(DIG(b,0), DIG(a,0), DIG(x,0), alen); x->sign = 1 ^ b->sign; } } else { x = alcbignum(blen); c = sub1(DIG(b,blen-alen), DIG(a,0), DIG(x,blen-alen), alen); subi1(DIG(b,0), -c, DIG(x,0), blen-alen); x->sign = 1 ^ b->sign; } } return mkdesc(x, dx); } else { /* integer - integer */ itobig(IntVal(*da), (struct b_bignum *)tdigits, &td); return bigsubi(&td, IntVal(*db), dx); } }/* * da * db -> dx */int bigmul(da, db, dx)dptr da, db, dx;{ struct b_bignum *a, *b, *x; word alen, blen; if (Type(*da) == T_Bignum && Type(*db) == T_Bignum) { alen = LEN(BigNum(da)); ble
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:rlargi
+++++ Continued from previous card +++++
n = LEN(BigNum(db)); if (blkreq(BigNeed(alen + blen)) == Error) return Error; a = BigNum(da); b = BigNum(db); x = alcbignum(alen + blen); mul1(DIG(a,0), DIG(b,0), DIG(x,0), alen, blen); x->sign = a->sign ^ b->sign; return mkdesc(x, dx); } else if (Type(*da) == T_Bignum) /* bignum * integer */ return bigmuli(da, IntVal(*db), dx); else if (Type(*db) == T_Bignum) /* integer * bignum */ return bigmuli(db, IntVal(*da), dx); else { /* integer * integer */ struct descrip td; char tdigits[INTBIGBLK]; itobig(IntVal(*da), (struct b_bignum *)tdigits, &td); return bigmuli(&td, IntVal(*db), dx); }}/* * da / db -> dx */ int bigdiv(da, db, dx)dptr da, db, dx;{ struct b_bignum *a, *b, *x; word alen, blen; if (Type(*da) == T_Bignum && Type(*db) == T_Bignum) { alen = LEN(BigNum(da)); blen = LEN(BigNum(db)); if (alen < blen) { MakeInt(0, dx); return Success; } if (blkreq(BigNeed(alen-blen+1)+BigNeed(alen+1)+BigNeed(blen)) == Error) return Error; a = BigNum(da); b = BigNum(db); x = alcbignum(alen - blen + 1); if (blen == 1) divi1(DIG(a,0), (word)*DIG(b,0), DIG(x,0), alen); else div1(DIG(a,0), DIG(b,0), DIG(x,0), NULL, alen-blen, blen); x->sign = a->sign ^ b->sign; return mkdesc(x, dx); } else if (Type(*da) == T_Bignum) /* bignum / integer */ return bigdivi(da, IntVal(*db), dx); else if (Type(*db) == T_Bignum) { /* integer / bignum */ MakeInt(0, dx); return Success; } /* not called for integer / integer */}/* * da % db -> dx */int bigmod(da, db, dx)dptr da, db, dx;{ struct b_bignum *a, *b, *x, *temp; word alen, blen; if (Type(*da) == T_Bignum && Type(*db) == T_Bignum) { alen = LEN(BigNum(da)); blen = LEN(BigNum(db)); if (alen < blen) { cpbignum(da, dx); return Success; } if (blkreq(BigNeed(blen)+BigNeed(alen+1)+BigNeed(blen)) == Error) return Error; a = BigNum(da); um(db); x = alcbignum(blen); if (blen == 1) { temp = alcbignum(alen); *DIG(x,0) = divi1(DIG(a,0), (word)*DIG(b,0), DIG(temp,0), alen); } else div1(DIG(a,0), DIG(b,0), NULL, DIG(x,0), alen-blen, blen); x->sign = a->sign; return mkdesc(x, dx); } else if (Type(*da) == T_Bignum) /* bignum % integer */ return bigmodi(da, IntVal(*db), dx); else if (Type(*db) == T_Bignum) { /* integer % bignum */ struct descrip td; char tdigits[INTBIGBLK]; itobig(IntVal(*da), (struct b_bignum *)tdigits, &td); cpbignum(&td, dx); return Success; } /* not called for integer % integer */}/* * -i -> dx */int bigneg(da, dx)dptr da, dx;{ struct descrip td; char tdigits[INTBIGBLK]; itobig(IntVal(*da), (struct b_bignum *)tdigits, &td); BigNum(&td)->sign ^= 1; return cpbignum(&td, dx);}/* * da ^ db -> dx */int bigpow(da, db, dx)dptr da, db, dx;{ word n; if (Type(*da) == T_Bignum && Type(*db) == T_Bignum) { if (BigNum(db)->sign) { MakeInt(0, dx); } else { n = LEN(BigNum(db)) * NB; /* scan bits left to right. skip leading 1. */ while (--n >= 0) if ((*DIG(BigNum(db), n / NB) & (1 << (n % NB)))) break; /* then, for each zero, square the partial result; * for each one, square it and multiply it by a */ *dx = *da; while (--n >= 0) { if (bigmul(dx, dx, dx) == Error) return Error; if ((*DIG(BigNum(db), n / NB) & (1 << (n % NB)))) if (bigmul(dx, da, dx) == Error) return Error; } } return Success; } else if (Type(*da) == T_Bignum) /* bignum ^ integer */ return bigpowi(da, IntVal(*db), dx); else if (Type(*db) == T_Bignum) /* integer ^ bignum */ return bigpowii(IntVal(*da), (word)bigtoreal(db), dx); else /* integer ^ integer */ return bigpowii(IntVal(*da), IntVal(*db), dx);}/* * iand(da, db) -> dx */int bigand(da, db, dx)dptr da, db, dx;{ struct b_bignum *a, *b, *x; word alen, blen, xlen; word i; struct b_bignum *tad, *tbd; DIGIT *ad, *bd; struct descrip td; char tdigits[INTBIGBLK]; if (Type(*da) == T_Bignum && Type(*db) == T_Bignum) { alen = LEN(BigNum(da)); blen = LEN(BigNum(db)); xlen = alen > blen ? alen : blen; if (blkreq(3 * BigNeed(xlen)) == Error) return Error; a = BigNum(da); b = BigNum(db); x = alcbignum(xlen); if (alen == xlen && !a->sign) ad = DIG(a,0); else { tad = alcbignum(xlen); ad = DIG(tad,0); bdzero(ad, xlen - alen); bdcopy(DIG(a,0), &ad[xlen-alen], alen); if (a->sign) compl1(ad, ad, xlen); } if (blen == xlen && !b->sign) bd = DIG(b,0); else { tbd = alcbignum(xlen); bd = DIG(tbd,0); bdzero(bd, xlen - blen); bdcopy(DIG(b,0), &bd[xlen-blen], blen); if (b->sign) compl1(bd, bd, xlen); } for (i = 0; i < xlen; i++) *DIG(x,i) = ad[i] & bd[i]; if (a->sign & b->sign) { x->sign = 1; compl1(DIG(x,0), DIG(x,0), xlen); } } else if (Type(*da) == T_Bignum) { /* iand(bignum,integer) */ itobig(IntVal(*db), (struct b_bignum *)tdigits, &td); alen = LEN(BigNum(da)); blen = LEN(BigNum(&td)); xlen = alen > blen ? alen : blen; if (blkreq(3 * BigNeed(alen)) == Error) return Error; a = BigNum(da); b = BigNum(&td); x = alcbignum(alen); if (alen == xlen && !a->sign) ad = DIG(a,0); else { tad = alcbignum(xlen); ad = DIG(tad,0); bdzero(ad, xlen - alen); bdcopy(DIG(a,0), &ad[xlen-alen], alen); if (a->sign) compl1(ad, ad, xlen); } if (blen == xlen && !b->sign) bd = DIG(b,0); else { tbd = alcbignum(xlen); bd = DIG(tbd,0); bdzero(bd, xlen - blen); bdcopy(DIG(b,0), &bd[xlen-blen], blen); if (b->sign) compl1(bd, bd, xlen); } for (i = 0; i < xlen; i++) *DIG(x,i) = ad[i] & bd[i]; if (a->sign & b->sign) { x->sign = 1; compl1(DIG(x,0), DIG(x,0), xlen); } } else if (Type(*db) == T_Bignum) { /* iand(integer,bignum) */ itobig(IntVal(*da), (struct b_bignum *)tdigits, &td); alen = LEN(BigNum(&td)); blen = LEN(BigNum(db)); xlen = alen > blen ? alen : blen; if (blkreq(3 * BigNeed(blen)) == Error) return Error; a = BigNum(&td); b = BigNum(db); x = alcbignum(blen); if (alen == xlen && !a->sign) ad = DIG(a,0); else { tad = alcbignum(xlen); ad = DIG(tad,0); bdzero(ad, xlen - alen); bdcopy(DIG(a,0), &ad[xlen-alen], alen); if (a->sign) compl1(ad, ad, xlen); } if (blen == xlen && !b->sign) bd = DIG(b,0); else { tbd = alcbignum(xlen); bd = DIG(tbd,0); bdzero(bd, xlen - blen); bdcopy(DIG(b,0), &bd[xlen-blen], blen); if (b->sign) compl1(bd, bd, xlen); } for (i = 0; i < xlen; i++) *DIG(x,i) = ad[i] & bd[i]; if (a->sign & b->sign) { x->sign = 1; compl1(DIG(x,0), DIG(x,0), xlen); } } /* not called for iand(integer,integer) */ return mkdesc(x, dx);}/* * ior(da, db) -> dx */int bigor(da, db, dx)dptr da, db, dx;{ struct b_bignum *a, *b, *x; word alen, blen, xlen; word i; struct b_bignum *tad, *tbd; DIGIT *ad, *bd; struct descrip td; char tdigits[INTBIGBLK]; if (Type(*da) == T_Bignum && Type(*db) == T_Bignum) { alen = LEN(BigNum(da)); blen = LEN(BigNum(db)); xlen = alen > blen ? alen : blen; if (blkreq(3 * BigNeed(xlen)) == Error) return Error; a = BigNum(da); b = BigNum(db); x = alcbignum(xlen); if (alen == xlen && !a->sign) ad = DIG(a,0); else { tad = alcbignum(xlen); ad = DIG(tad,0); bdzero(ad, xlen - alen); bdcopy(DIG(a,0), &ad[xlen-alen], alen); if (a->sign) compl1(ad, ad, xlen); } if (blen == xlen && !b->sign) bd = DIG(b,0); else { tbd = alcbignum(xlen); bd = DIG(tbd,0); bdzero(bd, xlen - blen); bdcopy(DIG(b,0), &bd[xlen-blen], blen); if (b->sign) compl1(bd, bd, xlen); } for (i = 0; i < xlen; i++) *DIG(x,i) = ad[i] | bd[i]; if (a->sign | b->sign) { x->sign = 1; compl1(DIG(x,0), DIG(x,0), xlen); } } else if (Type(*da) == T_Bignum) { /* ior(bignum,integer) */ itobig(IntVal(*db), (struct b_bignum *)tdigits, &td); alen = LEN(BigNum(da)); blen = LEN(BigNum(&td)); xlen = alen > blen ? alen : blen; if (blkreq(3 * BigNeed(alen)) == Error) return Error; a = BigNum(da); b = BigNum(&td); x = alcbignum(alen); if (alen == xlen && !a->sign) ad = DIG(a,0); else { tad = alcbignum(xlen); ad = DIG(tad,0); bdzero(ad, xlen - alen); bdcopy(DIG(a,0), &ad[xlen-alen], alen); if (a->sign) compl1(ad, ad, xlen); } if (blen == xlen && !b->sign) bd = DIG(b,0); else { tbd = alcbignum(xlen); bd = DIG(tbd,0); bdzero(bd, xlen - blen); bdcopy(DIG(b,0), &bd[xlen-blen], blen); if (b->sign) compl1(bd, bd, xlen); } for (i = 0; i < xlen; i++) *DIG(x,i) = ad[i] | bd[i]; if (a->sign | b->sign) { x->sign = 1; compl1(DIG(x,0), DIG(x,0), xlen); } } else if (Type(*db) == T_Bignum) { /* ior(integer,bignym) */ itobig(IntVal(*da), (struct b_bignum *)tdigits, &td); alen = LEN(BigNum(&td)); blen = LEN(BigNum(db)); xlen = alen > blen ? alen : blen; if (blkreq(3 * BigNeed(blen)) == Error) return Error; a = BigNum(&td); b = BigNum(db); x = alcbignum(blen); if (alen == xlen && !a->sign) ad = DIG(a,0); else { tad = alcbignum(xlen); ad = DIG(tad,0); bdzero(ad, xlen - alen); bdcopy(DIG(a,0), &ad[xlen-alen], alen); if (a->sign) compl1(ad, ad, xlen); } if (blen == xlen && !b->sign) bd = DIG(b,0); else { tbd = alcbignum(xlen); bd = DIG(tbd,0); bdzero(bd, xlen - blen); bdcopy(DIG(b,0), &bd[xlen-blen], blen); if (b->sign) compl1(bd, bd, xlen); } for (i = 0; i < xlen; i++) *DIG(x,i) = ad[i] | bd[i]; if (a->sign | b->sign) { x->sign = 1; compl1(DIG(x,0), DIG(x,0), xlen); } } /* not called for ior(integer,integer) */ return mkdesc(x, dx);}/* * xor(da, db) -> dx */int bigxor(da, db, dx)dptr da, db, dx;{ struct b_bignum *a, *b, *x; word alen, blen, xlen; word i; struct b_bignum *tad, *tbd; DIGIT *ad, *bd; struct descrip td; char tdigits[INTBIGBLK]; if (Type(*da) == T_Bignum && Type(*db) == T_Bignum) { alen = LEN(BigNum(da)); blen = LEN(BigNum(db)); xlen = alen > blen ? alen : blen; if (blkreq(3 * BigNeed(xlen)) == Error) return Error; a = BigNum(da); b = BigNum(db); x = alcbignum(xlen); if (alen == xlen && !a->sign) ad = DIG(a,0); else { tad = alcbignum(xlen); ad = DIG(tad,0); bdzero(ad, xlen - alen); bdcopy(DIG(a,0), &ad[xlen-alen], alen); if (a->sign) compl1(ad, ad, xlen); } if (blen == xlen && !b->sign) bd = DIG(b,0); else { tbd = alcbignum(xlen); bd = DIG(tbd,0); bdzero(bd, xlen - blen); bdcopy(DIG(b,0), &bd[xlen-blen], blen); if (b->sign) compl1(bd, bd, xlen); } for (i = 0; i < xlen; i++) *DIG(x,i) = ad[i] ^ bd[i]; if (a->sign ^ b->sign) { x->sign = 1; compl1(DIG(x,0), DIG(x,0), xlen); } } else if (Type(*da) == T_Bignum) { /* ixor(bignum,integer) */ itobig(IntVal(*db), (struct b_bignum *)tdigits, &td); alen = LEN(BigNum(da)); blen = LEN(BigNum(&td)); xlen = alen > blen ? alen : blen; if (blkreq(3 * BigNeed(alen)) == Error) return Error; a = BigNum(da); b = BigNum(&td); x = alcbignum(alen); if (alen == xlen && !a->sign) ad = DIG(a,0); else { tad = alcbignum(xlen); ad = DIG(tad,0); bdzero(ad, xlen - alen); bdcopy(DIG(a,0), &ad[xlen-alen], alen); if (a->sign) compl1(ad, ad, xlen); } if (blen == xlen && !b->sign) bd = DIG(b,0); else { tbd = alcbignum(xlen); bd = DIG(tbd,0); bdzero(bd, xlen - blen); bdcopy(DIG(b,0), &bd[xlen-blen], blen); if (b->sign) compl1(bd, bd, xlen); } for (i = 0; i < xlen; i++) *DIG(x,i) = ad[i] ^ bd[i]; if (a->sign ^ b->sign) { x->sign = 1; compl1(DIG(x,0), DIG(x,0), xlen); } } else if (Type(*db) == T_Bignum) { /* ixor(integer,bignum) */ itobig(IntVal(*da), (struct b_bignum *)tdigits, &td); alen = LEN(BigNum(&td)); blen = LEN(BigNum(db)); xlen = alen > blen ? alen : blen; if (blkreq(3 * BigNeed(blen)) == Error) return Error; a = BigNum(&td); b = BigNum(db); x = alcbignum(blen); if (alen == xlen && !a->sign) ad = DIG(a,0); else { tad = alcbignum(xlen); ad = DIG(tad,0); bdzero(ad, xlen - alen); bdcopy(DIG(a,0), &ad[xlen-alen], alen); if (a->sign) compl1(ad, ad, xlen); } if (blen == xlen && !b->sign) bd = DIG(b,0); else { tbd = alcbignum(xlen); bd = DIG(tbd,0); bdzero(bd, xlen - blen); bdcopy(DIG(b,0), &bd[xlen-blen], blen); if (b->sign) compl1(bd, bd, xlen); } for (i = 0; i < xlen; i++) *DIG(x,i) = ad[i] ^ bd[i]; if (a->sign ^ b->sign) { x->sign = 1; compl1(DIG(x,0), DIG(x,0), xlen); } } /* not called for ixor(integer,integer) */ return mkdesc(x, dx);}/* * bigshift(da, db) -> dx */int bigshift(da, db, dx)dptr da, db, dx;{ struct b_bignum *a, *x; word alen; word r = IntVal(*db) % NB; word q = (r >= 0 ? IntVal(*db) : (IntVal(*db) - (r += NB))) / NB; word xlen; DIGIT *ad; if (Type(*da) == T_Bignum) { alen = LEN(BigNum(da)); xlen = alen + q + 1; if (xlen <= 0) { MakeInt(0, dx); return Success; } else { if (blkreq(BigNeed(xlen) + BigNeed(alen)) == Error) return Error; a = BigNum(da); x = alcbignum(xlen); ad = DIG(a,0); if (q >= 0) { *DIG(x,0) = shifti1(ad, r, (DIGIT)0, DIG(x,1), alen); bdzero(DIG(x,alen+1), q); x->sign = a->sign; } else { *DIG(x,0) = shifti1(ad, r, ad[alen+q] >> (NB-r), DIG(x,1), alen+q); } return mkdesc
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:rlargi
+++++ Continued from previous card +++++
(x, dx); } } else { /* da is integer */ struct descrip td; char tdigits[INTBIGBLK]; itobig(IntVal(*da), (struct b_bignum *)tdigits, &td); alen = LEN(BigNum(&td)); xlen = alen + q + 1; if (xlen <= 0) { MakeInt(0, dx); return Success; } else { if (blkreq(BigNeed(xlen) + BigNeed(alen)) == Error) return Error; a = BigNum(&td); x = alcbignum(xlen); ad = DIG(a,0); if (q >= 0) { *DIG(x,0) = shifti1(ad, r, (DIGIT)0, DIG(x,1), alen); bdzero(DIG(x,alen+1), q); x->sign = a->sign; } else *DIG(x,0) = shifti1(ad, r, ad[alen+q] >> (NB-r), DIG(x,1), alen+q); return mkdesc(x, dx); } }}/* * negative if da < db * zero if da == db * positive if da > db */word bigcmp(da, db)dptr da, db;{ struct b_bignum *a = BigNum(da); struct b_bignum *b = BigNum(db); word alen, blen; if (Type(*da) == T_Bignum && Type(*db) == T_Bignum) { if (a->sign != b->sign) return (b->sign - a->sign); alen = LEN(a); blen = LEN(b); if (alen != blen) return (a->sign ? blen - alen : alen - blen); if (a->sign) return cmp1(DIG(b,0), DIG(a,0), alen); else return cmp1(DIG(a,0), DIG(b,0), alen); } else if (Type(*da) == T_Bignum) /* cmp(bignum, integer) */ return bigcmpi(da, IntVal(*db)); else /* cmp(integer, bignum) */ return -bigcmpi(db, IntVal(*da));}/* * ?da -> dx */ int bigrand(da, dx)dptr da, dx;{ struct b_bignum *a; word alen = LEN(BigNum(da)); struct b_bignum *x; struct b_bignum *td; DIGIT *d; word i; double rval; if (blkreq(4 * BigNeed(alen + 1) + 4) == Error) return Error; x = alcbignum(alen); td = alcbignum(alen + 1); d = DIG(td,0); a = BigNum(da); for (i = alen; i >= 0; i--) { rval = RandVal; d[i] = rval * B; } div1(d, DIG(a,0), NULL, DIG(x,0), (word)1, alen); addi1(DIG(x,0), (word)1, DIG(x,0), alen); return mkdesc(x, dx);} /* * da + i -> dx */static int bigaddi(da, i, dx)dptr da, dx;word i;{ struct b_bignum *a, *x; word alen; if (i < 0) return bigsubi(da, -i, dx); else if (i != (DIGIT)i) { struct descrip td; char tdigits[INTBIGBLK]; itobig(i, (struct b_bignum *)tdigits, &td); return bigadd(da, &td, dx); } else { alen = LEN(BigNum(da)); if (blkreq(BigNeed(alen + 1)) == Error) return Error; a = BigNum(da); if (a->sign) { x = alcbignum(alen); subi1(DIG(a,0), i, DIG(x,0), alen); } else { x = alcbignum(alen + 1); *DIG(x,0) = addi1(DIG(a,0), i, DIG(x,1), alen); } x->sign = a->sign; return mkdesc(x, dx); }}/* * da - i -> dx */static int bigsubi(da, i, dx)dptr da, dx;word i;{ struct b_bignum *a, *x; word alen; if (i < 0) return bigaddi(da, -i, dx); else if (i != (DIGIT)i) { struct descrip td; char tdigits[INTBIGBLK]; itobig(i, (struct b_bignum *)tdigits, &td); return bigsub(da, &td, dx); } else { alen = LEN(BigNum(da)); if (blkreq(BigNeed(alen + 1)) == Error) return Error; a = BigNum(da); if (a->sign) { x = alcbignum(alen + 1); *DIG(x,0) = addi1(DIG(a,0), i, DIG(x,1), alen); } else { x = alcbignum(alen); subi1(DIG(a,0), i, DIG(x,0), alen); } x->sign = a->sign; return mkdesc(x, dx); }}/* * da * i -> dx */static int bigmuli(da, i, dx)dptr da, dx;word i;{ struct b_bignum *a, *x; word alen; if (i <= -B || i >= B) { struct descrip td; char tdigits[INTBIGBLK]; itobig(i, (struct b_bignum *)tdigits, &td); return bigmul(da, &td, dx); } else { alen = LEN(BigNum(da)); if (blkreq(BigNeed(alen + 1)) == Error) return Error; a = BigNum(da); x = alcbignum(alen + 1); if (i >= 0) x->sign = a->sign; else { x->sign = 1 ^ a->sign; i = -i; } *DIG(x,0) = muli1(DIG(a,0), i, 0, DIG(x,1), alen); return mkdesc(x, dx); }}/* * da / i -> dx */static int bigdivi(da, i, dx)dptr da, dx;word i;{ struct b_bignum *a, *x; word alen; if (i <= -B || i >= B) { struct descrip td; char tdigits[INTBIGBLK]; itobig(i, (struct b_bignum *)tdigits, &td); return bigdiv(da, &td, dx); } else { alen = LEN(BigNum(da)); if (blkreq(BigNeed(alen)) == Error) return Error; a = BigNum(da); x = alcbignum(alen); if (i >= 0) x->sign = a->sign; else { x->sign = 1 ^ a->sign; i = -i; } divi1(DIG(a,0), i, DIG(x,0), alen); return mkdesc(x, dx); }}/* * da % i -> dx */static int bigmodi(da, i, dx)dptr da, dx;word i;{ struct b_bignum *a, *temp; word alen; word x; if (i <= -B || i >= B) { struct descrip td; char tdigits[INTBIGBLK]; itobig(i, (struct b_bignum *)tdigits, &td); return bigmod(da, &td, dx); } else { alen = LEN(BigNum(da)); if (blkreq(BigNeed(alen)) == Error) return Error; a = BigNum(da); temp = alcbignum(alen); x = divi1(DIG(a,0), Abs(i), DIG(temp,0), alen); if (a->sign) x = -x; MakeInt(x, dx); return Success; }}/* * da ^ i -> dx */static int bigpowi(da, i, dx)dptr da, dx;word i;{ int n = WordBits; if (i > 0) { /* scan bits left to right. skip leading 1. */ while (--n >= 0) if (i & ((word)1 << n)) break; /* then, for each zero, square the partial result; for each one, square it and multiply it by a */ *dx = *da; while (--n >= 0) { if (bigmul(dx, dx, dx) == Error) return Error; if (i & ((word)1 << n)) if (bigmul(dx, da, dx) == Error) return Error; } } else { MakeInt(0, dx); } return Success;}/* * a ^ i -> dx */static int bigpowii(a, i, dx)word a, i;dptr dx;{ word x, y; int n = WordBits; int isbig = 0; if (a == 0 || i <= 0) { /* special cases */ if (a == 0 && i <= 0) /* 0 ^ negative -> error */ RetError(-204, nulldesc); if (a == -1) { /* -1 ^ [odd,even] -> [-1,+1] */ if (!(i & 1)) a = 1; } else if (a != 1) { /* 1 ^ any -> 1 */ a = 0; } /* others ^ negative -> 0 */ MakeInt(a, dx); } else { struct descrip td; char tdigits[INTBIGBLK]; /* scan bits left to right. skip leading 1. */ while (--n >= 0) if (i & ((word)1 << n)) break; /* then, for each zero, square the partial result; for each one, square it and multiply it by a */ x = a; while (--n >= 0) { if (isbig) { if (bigmul(dx, dx, dx) == Error) return Error; } else { y = mul(x, x); if (!over_flow) x = y; else { itobig(x, (struct b_bignum *)tdigits, &td); if (bigmul(&td, &td, dx) == Error) return Error; isbig = (Type(*dx) == T_Bignum); } } if (i & ((word)1 << n)) { if (isbig) { if (bigmuli(dx, a, dx) == Error) return Error; } else { y = mul(x, a); if (!over_flow) x = y; else { itobig(x, (struct b_bignum *)tdigits, &td); if (bigmuli(&td, a, dx) == Error) return Error; isbig = (Type(*dx) == T_Bignum); } } } } if (!isbig) { MakeInt(x, dx); } } return Success;}/* * negative if da < i * zero if da == i * positive if da > i */ static word bigcmpi(da, i)dptr da;word i;{ struct b_bignum *a = BigNum(da); word alen = LEN(a); if (i > -B && i < B) { if (i >= 0) if (a->sign) return -1; else return cmpi1(DIG(a,0), i, alen); else if (a->sign) return -cmpi1(DIG(a,0), -i, alen); else return 1; } else { struct descrip td; char tdigits[INTBIGBLK]; itobig(i, (struct b_bignum *)tdigits, &td); return bigcmp(da, &td); }} /* These are all straight out of Knuth vol. 2, Sec. 4.3.1. *//* * (u,n) + (v,n) -> (w,n) * * returns carry, 0 or 1 */static DIGIT add1(u, v, w, n)DIGIT *u, *v, *w;word n;{ uword dig, carry; word i; carry = 0; for (i = n; --i >= 0; ) { dig = (uword)u[i] + v[i] + carry; w[i] = lo(dig); carry = hi(dig); } return carry;}/* * (u,n) - (v,n) -> (w,n) * * returns carry, 0 or -1 */static word sub1(u, v, w, n)DIGIT *u, *v, *w;word n;{ uword dig, carry; word i; carry = 0; for (i = n; --i >= 0; ) { dig = (uword)u[i] - v[i] + carry; w[i] = lo(dig); carry = signed_hi(dig); } return carry;}/* * (u,n) * (v,m) -> (w,m+n) */static novalue mul1(u, v, w, n, m)DIGIT *u, *v, *w;word n, m;{ word i, j; uword dig, carry; bdzero(&w[m], n); for (j = m; --j >= 0; ) { carry = 0; for (i = n; --i >= 0; ) { dig = (uword)u[i] * v[j] + w[i+j+1] + carry; w[i+j+1] = lo(dig); carry = hi(dig); } w[j] = carry; }}/* * (a,m+n) / (b,n) -> (q,m+1) (r,n) * * if q or r is NULL, the quotient or remainder is discarded */static novalue div1(a, b, q, r, m, n)DIGIT *a, *b, *q, *r;word m, n;{ uword qhat, rhat; uword dig, carry; struct b_bignum *tu, *tv; DIGIT *u, *v; word d; word i, j; /* blkreq's done in calling routines */ tu = alcbignum(m + n + 1); tv = alcbignum(n); u = DIG(tu,0); v = DIG(tv,0); /* D1 */ for (d = 0; d < NB; d++) if (b[0] & (1 << (NB - 1 - d))) break; u[0] = shifti1(a, d, (DIGIT)0, &u[1], m+n); shifti1(b, d, (DIGIT)0, v, n); /* D2, D7 */ for (j = 0; j <= m; j++) { /* D3 */ if (u[j] == v[0]) { qhat = B - 1; rhat = (uword)v[0] + u[j+1]; } else { uword numerator = dbl(u[j], u[j+1]); qhat = numerator / (uword)v[0]; rhat = numerator % (uword)v[0]; } while (rhat < B && qhat * v[1] > dbl(rhat, u[j+2])) { qhat -= 1; rhat += v[0]; } /* D4 */ carry = 0; for (i = n; i > 0; i--) { dig = u[i+j] - v[i-1] * qhat + carry; /* -BSQ+B .. B-1 */ u[i+j] = lo(dig); if ((uword)dig < B) carry = hi(dig); else carry = hi(dig) | -B; } carry = (word)(carry + u[j]) < 0; /* D5 */ if (q) q[j] = qhat; /* D6 */ if (carry) { if (q) q[j] -= 1; carry = 0; for (i = n; i > 0; i--) { dig = (uword)u[i+j] + v[i-1] + carry; u[i+j] = lo(dig); carry = hi(dig); } } } if (r) { if (d == 0) shifti1(&u[m+1], (word)d, (DIGIT)0, r, n); else r[0] = shifti1(&u[m+1], (word)(NB - d), u[m+n]>>d, &r[1], n - 1); }}/* * - (u,n) -> (w,n) * */static novalue compl1(u, w, n)DIGIT *u, *w;word n;{ uword dig, carry = 0; word i; for (i = n; --i >= 0; ) { dig = carry - u[i]; w[i] = lo(dig); carry = signed_hi(dig); }}/* * (u,n) : (v,n) */static word cmp1(u, v, n)DIGIT *u, *v;word n;{ word i; for (i = 0; i < n; i++) if (u[i] != v[i]) return u[i] > v[i] ? 1 : -1; return 0;}/* * (u,n) + k -> (w,n) * * k in 0 .. B-1 * returns carry, 0 or 1 */static DIGIT addi1(u, k, w, n)DIGIT *u, *w;word k;word n;{ uword dig, carry; word i; carry = k; for (i = n; --i >= 0; ) { dig = (uword)u[i] + carry; w[i] = lo(dig); carry = hi(dig); } return carry;}/* * (u,n) - k -> (w,n) * * k in 0 .. B-1 * u must be greater than k */static novalue subi1(u, k, w, n)DIGIT *u, *w;word k;word n;{ uword dig, carry; word i; carry = -k; for (i = n; --i >= 0; ) { dig = (uword)u[i] + carry; w[i] = lo(dig); carry = signed_hi(dig); }}/* * (u,n) * k + c -> (w,n) * * k in 0 .. B-1 * returns carry, 0 .. B-1 */static DIGIT muli1(u, k, c, w, n)DIGIT *u, *w;word k;int c;word n;{ uword dig, carry; word i; carry = c; for (i = n; --i >= 0; ) { dig = (uword)k * u[i] + carry; w[i] = l carry = hi(dig); } return carry;}/* * (u,n) / k -> (w,n) * * k in 0 .. B-1 * returns remainder, 0 .. B-1 */static DIGIT divi1(u, k, w, n)DIGIT *u, *w;word k;word n;{ uword dig, remain; word i; remain = 0; for (i = 0; i < n; i++) { dig = dbl(remain, u[i]); w[i] = dig / k; remain = dig % k; } return remain;}/* * ((u,n) << k) + c -> (w,n) * * k in 0 .. NB-1 * c in 0 .. B-1 * returns carry, 0 .. B-1 */static DIGIT shifti1(u, k, c, w, n)DIGIT *u, c, *w;word k;word n;{ uword dig; word i; if (k == 0) { bdcopy(u, w, n); return 0; } for (i = n; --i >= 0; ) { dig = ((uword)u[i] << k) + c; w[i] = lo(dig); c = hi(dig); } return c;}/* * (u,n) : k * * k in 0 .. B-1 */static word cmpi1(u, k, n)DIGIT *u;word k;word n;{ word i; for (i = 0; i < n-1; i++) if (u[i]) return 1; if (u[n - 1] == (DIGIT)k) return 0; return u[n - 1] > (DIGIT)k ? 1 : -1;}static novalue bdzero(dest, l)DIGIT *dest;word l;{ word i; for (i = 0; i < l; i++) dest[i] = 0;}static novalue bdcopy(src, dest, l)DIGIT *src, *dest;word l;{ word i; for (i = 0; i < l; i++) dest[i] = src[i];}#else /* LargeInts */static char x; /* prevent empty module */#endif /* LargeInts */ :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:rlocal.c
/* * Routines needed for different systems. */#include <math.h>#include "::h:config.h"#include "::h:rt.h"#include "rproto.h"#include <ctype.h>/* * The following code is operating-system dependent [@rlocal.01]. * Routines needed by different systems. */#if PORT /* place for anything system-specific */Deliberate Syntax Error#endif /* PORT */ #if AMIGA#if AZTEC_C/* * abs */abs(i)int i;{ return ((i<0)? (-i) : i);}/* * ldexp */double ldexp(value,exp)double value;{ double retval = 1.0; if(exp>0) { while(exp-->0) retval *= 2.0; } else if (exp<0) { while(exp++<0) retval = retval / 2.0; } return value * retval;}/* * abort() */novalue abort(){ fprintf(stderr,"ICON ERROR WITH ICONCORE SET\n"); fflush(stderr); exit(1);}#ifdef SystemFnc/* * Aztec C version 3.6 does not support system(), but here is a substitute. * This is a bonafide untested-original-it-just-compiles routine. * Manx will probably implement system() before we fix this version... */#include <ctype.h>#define KLUDGE1 256#define KLUDGE2 64int system(s)char *s;{ char text[KLUDGE1], *cp=text; char **av[KLUDGE2]; int ac = 0; int l = strlen(s); if (l >= KLUDGE1) return -1; strcpy(text,s); av[ac++] = text; while(*cp && ac<KLUDGE2-1) { if (isspace(*cp)) { *cp++ = '\0'; while(isspace(*cp)) cp++; if (*cp) av[ac++] = cp; } else { cp++; } } av[ac] = NULL; return fexecv(av[0], av);}#endif /* SystemFnc */#endif /* AZTEC_C */#endif /* AMIGA */ #if ATARI_ST#if LATTICElong _STACK = 10240;long _MNEED = 200000; /* reserve space for allocation (may be too large) */#include <osbind.h>/* Structure necessary for handling system time. */ struct tm { short tm_year; short tm_mon; short tm_wday; short tm_mday; short tm_hour; short tm_min; short tm_sec; };struct tm *localtime(clock) /* fill structure with clock time */int clock; /* millisecond timer value, if supplied; not used */{ static struct tm tv; unsigned int time, date; time = Tgettime(); date = Tgetdate(); tv.tm_year = ((date >> 9) & 0x7f) + 80; tv.tm_mon = ((date >> 5) & 0xf) - 1; tv.tm_mday = date & 0x1f; tv.tm_hour = (time >> 11) & 0x1f; tv.tm_min = (time >> 5) & 0x3f; tv.tm_sec = 2 * (time & 0x1f); tv.tm_wday = weekday(tv.tm_mday,tv.tm_mon+1,tv.tm_year); return(&tv);}weekday(day,month,year) /* find day of week from */short day, month, year; /* day, month, and year */{ /* Sunday..Saturday is 0..6 */ int index, yrndx, mondx; if(month <= 2) { /* Jan or Feb month adjust */ month += 12; year -= 1; } yrndx = year + (year / 4) - (year / 100) + (year / 400); mondx = 2 * month + (3 * (month + 1)) / 5; index = day + mondx + yrndx + 2; return(index % 7);}time(ptime) /* return value of millisecond timer */int *ptime;{ int tmp, ssp; /* value of supervisor stack pointer */ static int *tmr = (int *) 0x04ba; /* addr of timer */ ssp = gemdos(0x20,0); /* enter supervisor mode */ tmp = *tmr * 5; /* get millisecond timer */ ssp = gemdos(0x20,ssp); /* enter programmer mode */ if(ptime != NULL) *ptime = tmp; return(tmp);}int brk(p)char *p;{ char *sbrk(); long int l, m; l = (long int)p; m = (long int)sbrk(0); return((lsbrk((long) (l - m)) == 0) ? -1 : 0);}#ifdef LocalQsort/* Shell sort with some enhancements from Knuth.. */void qsort( base, nel, width, cmp ) /* was llqsort( ... */char *base; /*-also kqsort( ...-*/int nel;int width;int (*cmp)();{ register int i, j; long int gap; int k, tmp ; char *p1, *p2; for( gap=1; gap <= nel; gap = 3*gap + 1 ) ; for( gap /= 3; gap > 0 ; gap /= 3 ) for( i = gap; i < nel; i++ ) for( j = i-gap; j >= 0 ; j -= gap ) { p1 = base + ( j * width); p2 = base + ((j+gap) * width); if( (*cmp)( p1, p2 ) <= 0 ) break; for( k = width; --k >= 0 ;) { tmp = *p1; *p1++ = *p2; *p2++ = tmp; } }}#endif /* LocalQsort */#endif /* LATTICE */#endif /* ATARI_ST */ #if HIGHC_386#endif /* HIGHC_386 */ #if MACINTOSH#if MPW/*** Special routines for Macintosh Programmer's Workshop** implementation of the Icon Programming Language*/#include <Types.h>#include <Events.h>#include <OSUtils.h>#define MaxBlockX MaxBlock /* MaxBlock Icon definition conflicts */#undef MaxBlock /* with Mac Toolbox routine */#include <Memory.h>#define MaxBlock MaxBlockX#undef MaxBlockX#include <Errors.h>/*** Initialization and Termination Routines*//*** MacExit -- This function is installed by an onexit() call in MacInit** -- it is called automatically when the program terminates.*/voidMacExit(){ void ResetStack(); extern Ptr MemBlock; ResetStack(); if (MemBlock != NULL) DisposPtr(MemBlock);}/*** MacInit -- This function is called near the beginning of execution of** iconx. It is called by our own brk/sbrk initialization routine.*/voidMacInit(){ atexit(MacExit);}/*** Brk and Sbrk Equivalents*/typedef Ptr caddr_t;static caddr_t MemBlock, Break, Limit;word xcodesize;init_brk(){ static short init = 0; Size max, grow, size; char *v; extern word mstksize, statsize, ssize, abrsize; if (!init) { init = 1; MacInit(); if ((v = getenv("ICONSIZE")) != NULL) { /* if ICONSIZE defined */ if ((size = atol(v)) <= 0) { /* if ICONSIZE negative */ max = MaxMem(&grow); size = max + grow - (size < 0 ? -size : max / 4); } } else { /* if ICONSIZE undefined */ size = xcodesize + mstksize + statsize + ssize + abrsize + 512; } if ((MemBlock = NewPtr(size)) == NULL) { syserr("Unable to perform initial Icon memory allocation"); } Break = MemBlock; Limit = MemBlock + size; } return 1;}caddr_tbrk(addr)caddr_t addr;{ Size newsize; if (!init_brk()) return (caddr_t)-1; if (addr < MemBlock) return (caddr_t)-1; if (addr < Limit) Break = addr; else { newsize = addr - MemBlock; SetPtrSize(MemBlock, newsize); if (MemError() != noErr) return (caddr_t)-1; Break = Limit = addr; } return (caddr_t)0;}caddr_tsbrk(incr)int incr;{ caddr_t start; if (!init_brk()) return (caddr_t)-1; start = Break; if (incr != 0) { if (brk(start + incr) == (caddr_t)-1) return (caddr_t)-1; } return start;}#endif /* MPW */#endif /* MACINTOSH */ #if MSDOS#if TURBOextern unsigned _stklen = 8 * 1024;#endif /* TURBO */#if LATTICE#include <error.h>int _stack = (8 * 1024);long int _mneed = (20 * 1024);extern long int *sp;long int **xsp = &sp; /* Used for rswitch.asm .. since 'sp' is a reserved */ /* symbol for the assembler.. */extern char *statend; /* Indicator for when to use malloc for _GETBF */int brk(p)char *p;{ char *sbrk(); long int l, m; l = (long int)p; m = (long int)sbrk((word)0); if( lsbrk((long) (l - m) ) == 0) return -1; else return 0;}novalue abort() /* Abort set to 'dump' icon data area.. */{#ifdef DeBugIconx blkdump();#endif /* DeBugIconx */ fflush(stderr); fcloseall(); _exit(1);}#endif /* LATTICE */#endif /* MSDOS */ #if MVS || VMconst int _staksize = (64*1024);#endif /* MVS || VM */ #if OS2#endif /* OS2 */ #if UNIX#ifdef ATTM32/* * This file contains the routine necessary to allocate legal AT&T * 3B2/15/4000 stack space for co-expression stacks. * * Legal stack region begins at 0xC0020000, and UNIX will grow stack space * up to 50 Megabytes. 0xC0030000 should provide plenty of room for * main C stack growth. Each time coexpr_salloc() is called, it * adds mstksize (max main stack size) and returns a new address, * meaning each coexpression stack is potentially as large as the main stack. *//* * coexp_salloc() - return pointer in legal stack space for start * of a coexpression stack. */pointer coexp_salloc() { static pointer sp = 0xC0030000 ; /* pointer to stack region */ sp += mstksize; return sp;}#endif /* ATTM32 */#if CONVEX /* replacement pow() that allows negative ** integer */#undef powdouble pow0 (base, exp) double base, exp;{ if (base >= 0) return pow (base, exp); else { long n = exp; if (n != exp) runerr (-206, 0); else if (n & 1) return -pow (-base, exp); else return pow (-base, exp);}}#endif /* CONVEX */#endif /* UNIX */ #if VMS#include dvidef#include iodeftypedef struct _descr { int length; char *ptr;} descriptor;typedef struct _pipe { long pid; /* process id of child */ long status; /* exit status of child */ long flags; /* LIB$SPAWN flags */ int channel; /* MBX channel number */ int efn; /* ag to wait for */ char mode; /* the open mode */ FILE *fptr; /* file pointer (for fun) */ unsigned running : 1; /* 1 if child is running */} Pipe;Pipe _pipes[_NFILE]; /* one for every open file */#define NOWAIT 1#define NOCLISYM 2#define NOLOGNAM 4#define NOKEYPAD 8#define NOTIFY 16#define NOCONTROL 32#define SFLAGS (NOWAIT|NOKEYPAD|NOCONTROL) /* * popen - open a pipe command * Last modified 2-Apr-86/chj * * popen("command", mode) */FILE *popen(cmd, mode)char *cmd;char *mode;{ FILE *pfile; /* the Pfile */ Pipe *pd; /* _pipe database */ descriptor mbxname; /* name of mailbox */ descriptor command; /* command string descriptor */ descriptor nl; /* null device descriptor */ char mname[65]; /* mailbox name string */ int chan; /* mailbox channel number */ int status; /* system service status */ int efn; struct { short len; short code; char *address; char *retlen; int last; } itmlst; if (!cmd || !mode) return (0); LIB$GET_EF(&efn); if (efn == -1) return (0); if (_tolower(mode[0]) != 'r' && _tolower(mode[0]) != 'w') return (0); /* create and open the mailbox */ status = SYS$CREMBX(0, &chan, 0, 0, 0, 0, 0); if (!(status & 1)) { LIB$FREE_EF(&efn); return (0); } itmlst.last = mbxname.length = 0; itmlst.address = mbxname.ptr = mname; itmlst.retlen = &mbxname.length; itmlst.code = DVI$_DEVNAM; itmlst.len = 64; status = SYS$GETDVIW(0, chan, 0, &itmlst, 0, 0, 0, 0); if (!(status & 1)) { LIB$FREE_EF(&efn); return (0); } mname[mbxname.length] = '\0'; pfile = fopen(mname, mode); if (!pfile) { LIB$FREE_EF(&efn); SYS$DASSGN(chan); return (0); } /* Save file information now */ pd = &_pipes[fileno(pfile)]; /* get Pipe pointer */ pd->mode = _tolower(mode[0]); pd->fptr = pfile; pd->pid = pd->status = pd->running = 0; pd->flags = SFLAGS; pd->channel = chan; pd->efn = efn; /* fork the command */ nl.length = strlen("_NL:"); nl.ptr = "_NL:"; command.length = strlen(cmd); command.ptr = cmd; status = LIB$SPAWN(&command, (pd->mode == 'r') ? 0 : &mbxname, /* input file */ (pd->mode == 'r') ? &mbxname : 0, /* output file */ &pd->flags, 0, &pd->pid, &pd->status, &pd->efn, 0, 0, 0, 0); if (!(status & 1)) { LIB$FREE_EF(&efn); SYS$DASSGN(chan); return (0); } else { pd->running = 1; } return (pfile);} /* * pclose - close a pipe * Last modified 2-Apr-86/chj * */pclose(pfile)FILE *pfile;{ Pipe *pd; int status; int fstatus; pd = fileno(pfile) ? &_pipes[fileno(pfile)] : 0; if (pd == NULL) return (-1); fflush(pd->fptr); /* flush buffers */ fstatus = fclose(pfile); if (pd->mode == 'w') { status = SYS$QIOW(0, pd->channel, IO$_WRITEOF, 0, 0, 0, 0, 0, 0, 0, 0, 0); SYS$WFLOR(pd->efn, 1 << (pd->efn % 32)); } SYS$DASSGN(pd->channel); LIB$FREE_EF(&pd->efn); pd->running = 0; return (fstatus);} /* * redirect(&argc,argv,nfargs) - redirect standard I/O * int *argc number of command arguments (from call to main) * char *argv[] command argument list (from call to main) * int nfargs number of filename arguments to process * * argc and argv will be adjusted by redirect. * * redirect processes a program's command argument list and handles redirection * of stdin, and stdout. Any arguments which redirect I/O are removed from the * argument list, and argc is adjusted accordingly. redirect would typically be * called as the first statement in the main program. * * Files are redirected based on syntax or position of command arguments. * Arguments of the following forms always redirect a file: * * <file redirects standard input to read the given file * >file redirects standard output to write to the given file * >>file redirects standard output to append to the given file * * It is often useful to allow alternate input and output files as the * first two command arguments without requiring the <file and >file * syntax. If the nfargs argument to redirect is 2 or more then the * first two command arguments, if supplied, will be interpreted in this * manner: the first argument replaces stdin and the second stdout. * A filename of "-" may be specified to occupy a position without * performing any redirection. * * If nfargs is 1, only the first argument will be considered and will * replace standard input if given. Any arguments processed by setting * nfargs > 0 will be removed from the argument list, and again argc will * be adjusted. Positional redirection follows syntax-specified * redirection and therefore overrides it. * */redirect(argc,argv,nfargs)int *argc, nfargs;char *argv[];{ int i; i = 1; while (i < *argc) { /* for every command argument... */ switch (argv[i][0]) { /* check first character */ case '<': /* <file redirects stdin */ filearg(argc,argv,i,1,stdin,"r"); break; case '>': /* >file or >>file redirects stdout */ if (argv[i][1] == '>') filearg(argc,argv,i,2,stdout,"a"); else filearg(argc,argv,i,1,stdout,"w"); break; default: /* not recognized, go on to next arg */ i++; } } if (nfargs >= 1 && *argc > 1) /* if positional redirection & 1 arg */ filearg(argc,argv,1,0,stdin,"r"); /* then redirect stdin */ if (nfargs >= 2 && *argc > 1) /* likewise for 2nd arg if wanted */ filearg(argc,argv,1,0,stdout,"w");/* redirect stdout */}/* filearg(&argc,argv,n,i,fp,mode) - redirect and remove file argument * int *argc number of command arguments (from call to main) * char *argv[] command argument list (from call to main) * int n argv entry to use as file name and then delete * int i first character of file name to use (skip '<' etc.) * FILE *fp file pointer for file to reopen (typically stdin etc.) * char mode[] file access mode (see freopen spec) */filearg(argc,argv,n,i,fp,mode)int *argc, n, i;char *argv[], mode[];FILE *fp;{ if (strcmp(argv[n]+i,"-")) /* alter file if arg not "-" */ fp = freopen(argv[n]+i,mode,fp); if (fp == NULL) { /* abort on error */ fprintf(stderr,"%%can't open %s",argv[n]+i); exit(ErrorExit); } for ( ; n < *argc; n++) /* move down following arguments */ argv[n] = argv[n+1]; *argc = *argc - 1; /* decrement argument count */} /* Special versions of sbrk() and brk() for use by Icon under VMS. * #defines in define.h actually rename these to vms_brk and vms_sbrk. * * F
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:rlocal
+++++ Continued from previous card +++++
or historical reasons, Icon assumes it can repeatedly call brk/sbrk * and always get contiguous chunks. This was made to work under Unix by * overloading the definitions of malloc and friends, the only other callers * of sbrk, and making them return Icon-managed memory. * Under VMS, sbrk is not the lowest-level system interface. It gets memory * from underlying VMS routines such as SYS$EXPREG. These routines are also * called by others, for example when a file is opened; so successive sbrk * calls may return nonadjacent chunks. This makes overloading malloc and * friends futile. * * The routines below replace sbrk and brk for Icon (only) under VMS. They * provide the continuously growing memory Icon needs without relying on * special privileges or unusually large quotas. Like the Unix solution and * earlier VMS attempts, this is an empirical solution and may need further * revision as the system changes. But we hope not. * * The Icon interpreter is loaded beginning at address 0 and grows upward as * it requests more memory through sbrk. The C stack grows downward from * 0x7FFFFFFF. We're going to draw a line to divide the address space, then * force the C and VMS runtime systems to put anything they need above it; * then sbrk can grow the program region unimpeded up to the line. * * The line is drawn MAXMEM bytes beyond thof the sbrk region. MAXMEM * is an environment variable (logical name to VMS) with a default as given in * define.h. Large values cost CPU and real time expended at process exit; we * don't know why. On an 8600 the cost was very roughly .04 CP sec / megabyte. * * When first called, sbrk expands the program region by one page to get a * starting address. A limit address is calculated by adding MAXMEM. A single * page created just below the limit address "draws the line" and causes the * VMS runtime system to allocate anything it needs above that point. sbrk * creates pages between base and limit as needed. * * Possible errors and their manifestations: * * MAXMEM too large to initialize sbrk: * error in startup code: value of MAXMEM too large * * MAXMEM too small to initialize sbrk: * error in startup code: value of MAXMEM too small * * MAXMEM too small for subsequent brk/sbrk growth * Run-time error 351: insufficient MAXMEM limit * * MAXMEM okay but insufficient user quota for needed memory: * Run-time error 303: unable to expand memory region * * unexpected ("can't happen") failures of system calls: * these produce their standard VMS error message * * unexpected intrusion into the sbrk region by the runtime system: * unknown, but undoubtedly ugly */#define PageSize 512 /* size of a VMS page */#define MaxP0 0x40000000 /* first address beyond the P0 region */#include <stsdef.h>word memsize = MaxMem; /* set from environment variable MAXMEM *//* sbrk(incr) - adjust the break value by incr, rounding up to a page. * returns the new break value, or -1 if unsuccessful. */char *sbrk(incr)int incr;{ static char *base; /* base of the sbrk region */ static char *curr; /* current break value (end+1) */ static char *limit; /* region limit ("the line") */ char *range[2], *p; /* scratch for system calls */ int s; /* status return from calls */ /* initialization code */ if (!base) { s = sys$expreg(1,range,0,0); /* expand P0 to get base address */ if (!(s & STS$M_SUCCESS)) exit(s); /* couldn't get one page?! */ base = curr = range[0]; /* initialize empty sbrk region */ memsize = (memsize + PageSize - 1) & -PageSize; /* round memsize to page boundary */ limit = base + memsize; /* calculate sbrk region limit*/ if (limit > MaxP0) limit = MaxP0; /* limit to legal values */ if (limit <= base) error("value of MAXMEM too small"); /* can't even start */ range[0] = range[1] = limit-1; s = sys$cretva(range,range,0); /* get a page there to draw the line */ if (!(s & STS$M_SUCCESS)) error("value of MAXMEM too large"); /* can't even start */ } if (incr > 0) { /* grow the region */ if (curr + incr > limit) /* check address space available */ fatalerr(-351,NULL); /* oops, MAXMEM too small */ range[0] = curr; range[1] = curr + incr - 1; s = sys$cretva(range,range,0); /* ask for the pages */ if (!(s & STS$M_SUCCESS)) return (char *) -1; /* failed, quota exceeded */ curr = range[1] + 1; /* set new break value as returned */ } else if (incr < 0) { /* shrink the region (not expected to be used). does not actually * return the memory, but does make it available for reuse. */ curr -= -incr & -PageSize; } /* return the current break value */ return curr;}/* brk(addr) - set the break address to the given value, rounded up to a page. * returns 0 if successful, -1 if not. */char *brk(addr)char *addr;{ return ((sbrk(addr-sbrk(0))) == (char *) -1 ? (char *) -1 : 0);}#endif /* VMS *//* * End of operating-system specific code. */static char x; /* avoid empty module */ :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:rmemexp.c
/* * File: rmemexp.c - memory management functions for expandable regions * Contents: initalloc, reclaim, malloc, calloc, free *//* * Prototypes. */hidden novalue moremem Params((uword units));hidden novalue reclaim Params((int region));word xcodesize;/* * initalloc - initialization routine to allocate memory regions */novalue initalloc(codesize)word codesize; { xcodesize = codesize; /* * Establish icode region */ code = (char *)sbrk((word)0); /* * Set up allocated memory. The regions are: * * Static memory region * Allocated string region * Allocate block region * Qualifier list */ statfree = statbase = (char *)((uword)(code + codesize + 3) & ~03);/* * The following code is operating-system dependent [@rmemexp.01]. Set end of * static region, rounding up if necessary. */#if PORT statend = (char *)(((uword)statbase) + mstksize + statsize);Deliberate Syntax Error#endif /* PORT */#if AMIGA || HIGHC_386 || MVS || OS2 || VM /* uses FixedRegions */#endif /* AMIGA || HIGHC_386 || ... */#if MSDOS statend = (char *)(((uword)statbase) + (((mstksize + statsize + 511)/512) * 512));#endif /* MSDOS */#if MACINTOSH#if MPW statend = (char *)(((uword)statbase) + mstksize + statsize);#endif /* MPW */#endif /* MACINTOSH */#if ATARI_ST || UNIX || VMS statend = (char *)(((uword)statbase) + mstksize + statsize);#endif /* ATARI_ST || UNIX || VMS *//* * End of operating-system specific code. */ strfree = strbase = (char *)((uword)(statend + 63) & ~077); blkfree = blkbase = strend = (char *)((((uword)strbase) + ssize + 63) & ~077); equallist = (dptr *)(blkend = (char *)((((uword)(blkbase) + abrsize + 63)) & ~077)); /* * Try to move the break back to the end of memory to allocate (the * end of the string qualifier list) and die if the space isn't * available. */ if ((int)brk((char *)equallist) == -1) error("insufficient memory"); currend = (char *)sbrk((word)0); /* keep track of end of memory */ } /* * reclaim - reclaim space in the allocated memory regions. The marking * phase has already been completed. */static novalue reclaim(region)int region;{ register word stat_extra, str_extra, blk_extra; register char *newend; stat_extra = 0; str_extra = 0; blk_extra = 0; /* * Collect available co-expression blocks. */ cofree(); /* * If there was no room to construct the qualifier list, the string * region cannot be collected and the static region cannot be expanded. */ if (!qualfail) { /* * Check whether the static region needs to be expanded. Regions cannot * be expanded if someone else has moved the end of allocated storage. */ if (statneed && currend == sbrk((word)0)) { /* * Make sure there is space for the requested static region expansion. * The check involving equallist and newend appears to only be * required on machines where the above addition of statneed might * overflow. */ newend = (char *)equallist + statneed; if ((uword)newend >= (uword)(char *)equallist && (int)brk((char *)newend) != -1) { stat_extra = statneed; statneed = 0; statend += stat_extra; equallist = (dptr *)newend; currend = sbrk((word)0); } } /* * Collect the string space, indicating that it must be moved back * extra bytes. */ scollect(stat_extra); if (region == Strings && currend == sbrk((word)0)) { /* * Calculate a value for extra space. The value is (the larger of * (twice the string space needed) or (a quarter of the string space)) * minus the unallocated string space. */ str_extra = (Max(2*strneed, ((uword)strend - (uword)strbase)/4) - ((uword)strend - (uword)strfree) + (GranSize-1)) & ~(GranSize-1); while (str_extra > 0) { /* * Try to get str_extra more bytes of storage. If it can't be * gotten, decrease the value by GranSize and try again. If * it's gotten, move back equallist. */ newend = (char *)equallist + str_extra; if ((uword)newend >= (uword)(char *)equallist && (int)brk((char *)newend) != -1) { equallist = (dptr *) newend; currend = sbrk((word)0); break; } str_extra -= GranSize; } if (str_extra < 0) str_extra = 0; } } /* * Adjust the pointers in the block region. */ adjust(blkbase, blkbase + stat_extra + str_extra); /* * Compact the block region. */ compact(blkbase); if (region == Blocks && currend == sbrk((word)0)) { /* * Calculate a value for extra space. The value is (the larger of * (twice the block region space needed) or (one quarter of the * block region)) plus the unallocated block space. */ blk_extra = (Max(2*blkneed, ((uword)blkend - (uword)blkbase)/4) - ((uword)blkend - (uword)blkfree) + (GranSize-1)) & ~(GranSize-1); while (blk_extra > 0) { /* * Try to get blk_extra more bytes of storage. If it can't be gotten, * decrease the value by GranSize and try again. If it's gotten, * move back equallist. */ newend = (char *)equallist + blk_extra; if ((uword)newend >= (uword)(char *)equallist && (int)brk((char *)newend) != -1) { equallist = (dptr *) newend; currend = sbrk((word)0); break; } blk_extra -= GranSize; } if (blk_extra < 0) blk_extra = 0; } if (stat_extra + str_extra > 0) { /* * The block region must be moved. There is an assumption here that the * block region always moves up in memory, i.e., the static and * string regions never shrink. With this assumption in hand, * the block region must be moved before the string space lest the * string space overwrite block data. The assumption is valid, * but beware if shrinking regions are ever implemented. */ mvc((uword)blkfree - (uword)blkbase, blkbase, blkbase + stat_extra + str_extra); blkbase += stat_extra + str_extra; blkfree += stat_extra + str_extra; } blkend += stat_extra + str_extra + blk_extra; if (stat_extra > 0) { /* * The string space must be moved up in memory. */ mvc((uword)strfree - (uword)strbase, strbase, strbase + stat_extra); strbase += stat_extra; strfree += stat_extra; } strend += stat_extra + str_extra; } /* * These are Icon's own versions of the allocation routines. They are * not used for the fixed-regions versions of memory management. They * normally overload the corresponding library routines. If this is not * possible, they are re-named and calls to them are renamed. */static HEADER base; /* start with empty list */static HEADER *allocp = NULL; /* last allocated block */pointer malloc(nbytes)msize nbytes; { register HEADER *p, *q; register uword nunits; register pointer xbase; int attempts; if (statbase == NULL) { if ((xbase = sbrk(nbytes)) == (pointer)-1) syserr("malloc: failed during startup"); return xbase; } nunits = 1 + (nbytes + sizeof(HEADER) - 1) / sizeof(HEADER); if ((q = allocp) == NULL) { /* no free list yet */ base.s.ptr = allocp = q = &base; base.s.bsize = 0; } for (attempts = 2; attempts--; q = allocp) { for (p = q->s.ptr;; q = p, p = p->s.ptr) { if (p->s.bsize >= nunits) { /* block is big enough */ if (p->s.bsize == nunits) /* exactly right */ q->s.ptr = p->s.ptr; else { /* allocate tail end */ p->s.bsize -= nunits; p += p->s.bsize; p->s.bsize = nunits; } allocp = q;#ifdef MemMon if (nunits > 1) { MMStat((char *)(p + 1), (word) nbytes, 'A'); *(int *)(p + 1) = 0; /* clear FREEMAGIC flag */ }#endif /* MemMon */ return (char *)(p + 1); } if (p == allocp) { /* wrap around */ moremem(nunits); /* garbage collect and expand if needed */ break; } } } return NULL; } #define FREESIZE 2 /* units sizeof(HEADER) that justify free() *//* * realloc() allocates a block of memory of a requested size (amount) to * contain the contents of the current block (curmem) or as much as will * fit. Blocks are allocated in units of sizeof(HEADER) */pointer realloc(curmem,newsiz)register pointer curmem; /* the current memory pointer */msize newsiz; /* bytes needed for new allocation */ { register int cunits; /* currently allocated units */ register int nunits; /* new units required */ char *newmem; /* the new memory pointer */ register HEADER *head; /* all blocks used or free have a header */ /* * First establish the unit sizes involved. */ nunits = 1 + (newsiz + sizeof(HEADER) - 1) / sizeof(HEADER); head = ((HEADER *)curmem) - 1; /* move back a block header */ cunits = (int)head->s.bsize; /* * Now allocate or free space as required. */ if (nunits <= cunits) { /* we already have the space */ if (cunits - nunits < FREESIZE) return curmem; else { /* free space at end of current block */ head->s.bsize = nunits; /* reduce space used */ head += nunits; /* move to free space */ head->s.bsize = cunits - nunits; free((pointer)(++head)); /* free this new block */ return curmem; } } else { /* more space needed */ if ((newmem = malloc((msize)newsiz)) != NULL) { memcopy(newmem,curmem,(word)((cunits - 1) * sizeof(HEADER))); free(curmem); return newmem; } } return NULL; } /* * calloc() allocates ecnt number of esiz-sized chunks of zero-initialized * memory for an array of ecnt elements. */pointer calloc(ecnt,esiz) register msize ecnt, esiz; { register char *mem; /* the memory pointer */ register msize amount; /* the amount of memory needed */ amount = ecnt * esiz; if ((mem = malloc(amount)) != NULL) { memfill(mem,0,(word)amount); /* initialize it to zero */ return mem; } return NULL; } static novalue moremem(nunits)uword nunits; { register HEADER *up; register word rnu; word n; rnu = NALLOC * ((nunits + NALLOC - 1) / NALLOC); n = rnu * sizeof(HEADER); if (((uword)statfree) + n > (uword)statend) { statneed = ((n / statincr) + 1) * statincr; coll_stat++; collect(Static); } /* * See if there is any room left. */ if ((uword)statend - (uword)statfree > sizeof(HEADER)) { up = (HEADER *) statfree; up->s.bsize = ((uword)statend - (uword)statfree) / sizeof(HEADER); statfree = (char *) (up + up->s.bsize); free((pointer)(up + 1)); /* add block to free memory */ } } #if LATTICE || LSC#define nothing 0int free(ap)#else /* LATTICE || LSC */#define nothingnovalue free(ap) /* return block pointed to by ap to free list */#endif /* LATTICE || LSC */pointer ap; { register HEADER *p, *q;/* free may be called to free a block before the static region is * initialized. */ if (statbase == (char *)NULL || (char *)ap < statbase) return nothing; p = (HEADER *)ap - 1; /* point to header */#ifdef MemMon if (p->s.bsize > 1) { if (*(int *)(p + 1) != T_Coexpr) MMStat((char *)ap, (word)((p->s.bsize - 1) * sizeof(HEADER)), 'F'); *(int *)(p + 1) = FREEMAGIC; }#endif /* MemMon */ if (p->s.bsize * sizeof(HEADER) >= statneed) statneed = 0; for (q = allocp; !((uword)p > (uword)q && (uword)p < (uword)q->s.ptr); q = q->s.ptr) if ((uword)q >= (uword)q->s.ptr && ((uword)p > (uword)q || (uword)p < (uword)q->s.ptr)) break; /* at one end or the other */ if ((uword)p + sizeof(HEADER) * p->s.bsize == (uword)q->s.ptr) { /* join to upper */ p->s.bsize += q->s.ptr->s.bsize; if (p->s.bsize * sizeof(HEADER) >= statneed) statneed = 0; p->s.ptr = q->s.ptr->s.ptr; } else p->s.ptr = q->s.ptr; if ((uword)q + sizeof(HEADER) * q->s.bsize == (uword)p) { /* join to lower */ q->s.bsize += p->s.bsize; if (q->s.bsize * sizeof(HEADER) >= statneed) statneed = 0; q->s.ptr = p->s.ptr; } else q->s.ptr = p; allocp = q; } :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:rmemfix.c
/* * File: rmemfix.c - memory managemnt functions for fixed regions * Contents: initalloc, reclaim *//* * Prototype. */hidden novalue reclaim Params((int region));/* * initalloc - initialization routine to allocate memory regions */novalue initalloc(codesize)word codesize; { static char dummy[1]; /* dummy static region */ /* * Allocate icode region */ if ((code = (char *)AllocReg(codesize)) == NULL) error("insufficient memory for icode"); /* * Set up allocated memory. The regions are: * Static memory region (not used) * Allocated string region * Allocate block region * Qualifier list */ statend = statfree = statbase = dummy; if ((strfree = strbase = (char *)AllocReg(ssize)) == NULL) error("insufficient memory for string region"); strend = strbase + ssize; if ((blkfree = blkbase = (char *)AllocReg(abrsize)) == NULL) error("insufficient memory for block region"); blkend = blkbase + abrsize; if ((quallist = (dptr *)AllocReg(qualsize)) == NULL) error("insufficient memory qualifier list"); equallist = (dptr *)((char *)quallist + qualsize); } /* * reclaim - reclaim space in the allocated memory regions. The marking * phase has already been completed. */static novalue reclaim(region)int region; { /* * Collect available co-expression blocks. */ cofree(); /* * Collect the string space leaving it where it is. */ if (!qualfail) scollect((word)0); /* * Adjust the blocks in the block region in place. */ adjust(blkbase,blkbase); /* * Compact the block region. */ compact(blkbase); } :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:rmemmgt.c
/* * File: rmemmgt.c * Contents: allocation routines, block description arrays, dump routines, * garbage collection, sweep */#include "::h:config.h"#include "::h:rt.h"#include "rproto.h"#if MACINTOSH#if MPW#include <QuickDraw.h>#include <ToolUtils.h>#endif /* MPW */#endif /* MACINTOSH */#ifdef IconAlloc/* * If IconAlloc is defined the system allocation routines are not overloaded. * The names are changed so that Icon's allocation routines are independently * used. This works as long as no other system calls cause the break value * to change. */#define malloc mem_alloc#define free mem_free#define realloc mem_realloc#define calloc mem_calloc#endif /* IconAlloc *//* * Prototype. */hidden union block *alcblk Params((uword nbytes,int tcode));word coexp_ser = 1; /* serial numbers for co-expressions; &main is 1 */word list_ser = 1; /* serial numbers for lists */word set_ser = 1; /* serial numbers for sets */word table_ser = 1; /* serial numbers for tables */word coll_stat = 0; /* collections in static region */word coll_str = 0; /* collections in string region */word coll_blk = 0; /* collections in block region */word coll_tot = 0; /* total collections */#ifdef EvalTraceextern FILE *trfile;extern word colmno;extern word lineno;#endif /* EvalTrace */#ifdef FixedRegionsword alcnum = 0; /* co-expressions allocated since g.c. */#endif /* FixedRegions */dptr *quallist; /* string qualifier list */dptr *qualfree; /* qualifier list free pointer */dptr *equallist; /* end of qualifier list */int qualfail; /* flag: quailifier list overflow *//* * Note: function calls beginning with "MM" are just empty macros * unless MemMon is defined. */ /* * Allocated block size table (sizes given in bytes). A size of -1 is used * for types that have no blocks; a size of 0 indicates that the * second word of the block contains the size; a value greater than * 0 is used for types with constant sized blocks. */int bsizes[] = { -1, /* T_Null (0), not block */ -1, /* T_Integer (1), not block */#ifdef LargeInts 0, /* T_Bignum (2), bignum */#else -1, /* (2), not used */#endif /* LargeInts */ sizeof(struct b_real), /* T_Real (3), real number */ sizeof(struct b_cset), /* T_Cset (4), cset */ sizeof(struct b_file), /* T_File (5), file block */ 0, /* T_Proc (6), procedure block */ sizeof(struct b_list), /* T_List (7), list header block */ sizeof(struct b_table), /* T_Table (8), table header block */ 0, /* T_Record (9), record block */ sizeof(struct b_telem), /* T_Telem (10), table element block */ 0, /* T_Lelem (11), list element block */ sizeof(struct b_tvsubs), /* T_Tvsubs (12), substring trapped variable */ -1, /* T_Tvkywd (13), keyword trapped variable */ sizeof(struct b_tvtbl), /* T_Tvtbl (14), table element trapped variable */ sizeof(struct b_set), /* T_Set (15), set header block */ sizeof(struct b_selem), /* T_Selem (16), set element block */ 0, /* T_Refresh (17), refresh block */ -1, /* T_Coexpr (18), co-expression block */ 0, /* T_External (19), external block */ 0, /* T_Slots (20), set/table hash block */ }; /* * Table of offsets (in bytes) to first descriptor in blocks. -1 is for * types not allocated, 0 for blocks with no descriptors. */int firstd[] = { -1, /* T_Null (0), not block */ -1, /* T_Integer (1), not block */#ifdef LargeInts 0, /* T_Bignum (2), bignum */#else -1, /* (2), not used */#endif /* LargeInts */ 0, /* T_Real (3), real number */ 0, /* T_Cset (4), cset */ 3*WordSize, /* T_File (5), file block */ 7*WordSize, /* T_Proc (6), procedure block */ 0, /* T_List (7), list header block */ (4+HSegs)*WordSize, /* T_Table (8), table header block */ 4*WordSize, /* T_Record (9), record block */ 3*WordSize, /* T_Telem (10), table element block */ 7*WordSize, /* T_Lelem (11), list element block */ 3*WordSize, /* T_Tvsubs (12), substring trapped variable */ -1, /* T_Tvkywd (13), keyword trapped variable */ 3*WordSize, /* T_Tvtbl (14), table element trapped variable */ 0, /* T_Set (15), set header block */ 3*WordSize, /* T_Selem (16), set element block */ (4+Wsizeof(struct pf_marker))*WordSize, /* T_Refresh (17), refresh block */ -1, /* T_Coexpr (18), co-expression block */ 0, /* T_External (19), external block */ 0, /* T_Slots (20), set/table hash block */ }; /* * Table of offsets (in bytes) to first pointer in blocks. -1 is for * types not allocated, 0 for blocks with no pointers. */int firstp[] = { -1, /* T_Null (0), not block */ -1, /* T_Integer (1), not block */#ifdef LargeInts 0, /* T_Bignum (2), bignum */#else -1, /* (2), not used */#endif /* LargeInts */ 0, /* T_Real (3), real number */ 0, /* T_Cset (4), cset */ 0, /* T_File (5), file block */ 0, /* T_Proc (6), procedure block */ 3*WordSize, /* T_List (7), list header block */ 4*WordSize, /* T_Table (8), table header block */ 3*WordSize, /* T_Record (9), record block */ 1*WordSize, /* T_Telem (10), table element block */ 2*WordSize, /* T_Lelem (11), list element block */ 0, /* T_Tvsubs (12), substring trapped variable */ -1, /* T_Tvkywd (13), keyword trapped variable */ 1*WordSize, /* T_Tvtbl (14), table element trapped variable */ 4*WordSize, /* T_Set (15), set header block */ 1*WordSize, /* T_Selem (16), set element block */ 0, /* T_Refresh (17), refresh block */ -1, /* T_Coexpr (18), co-expression block */ 0, /* T_External (19), external block */ 2*WordSize, /* T_Slots (20), set/table hash block */ }; /* * Table of number of pointers in blocks. -1 is for types not allocated and * types without pointers, 0 for pointers through the end of the block. */int ptrno[] = { -1, /* T_Null (0), not block */ -1, /* T_Integer (1), not block */ -1, /* T_Bignum (2), large integer, or not used */ -1, /* T_Real (3), real number */ -1, /* T_Cset (4), cset */ -1, /* T_File (5), file block */ -1, /* T_Proc (6), procedure block */ 2, /* T_List (7), list header block */ HSegs, /* T_Table (8), table header block */ 1, /* T_Record (9), record block */ 1, /* T_Telem (10), table element block */ 2, /* T_Lelem (11), list element block */ -1, /* T_Tvsubs (12), substring trapped variable */ -1, /* T_Tvkywd (13), keyword trapped variable */ 1, /* T_Tvtbl (14), table element trapped variable */ HSegs, /* T_Set (15), set header block */ 1, /* T_Selem (16), set element block */ -1, /* T_Refresh (17), refresh block */ -1, /* T_Coexpr (18), co-expression block */ -1, /* T_External (19), external block */ 0, /* T_Slots (20), set/table hash block */ }; /* * Table of block names used by debugging functions. */char *blkname[] = { "illegal object", /* T_Null (0), not block */ "illegal object", /* T_Integer (1), not block */#ifdef LargeInts "large integer", /* T_Bignum (2), bignum */#else "illegal object", /* not used */#endif /* LargeInts */ "real number", /* T_Real (3) */ "cset", /* T_Cset (4) */ "file", /* T_File (5) */ "procedure", /* T_Proc (6) */ "list", /* T_List (7) */ "table", /* T_Table (8) */ "record", /* T_Record (9) */ "table element", /* T_Telem (10) */ "list element", /* T_Lelem (11) */ "substring trapped variable", /* T_Tvsubs (12) */ "keyword trapped variable", /* T_Tvkywd (13) */ "table element trapped variable", /* T_Tvtbl (14) */ "set", /* T_Set (15) */ "set elememt", /* T_Selem (16) */ "refresh block", /* T_Refresh (17) */ "co-expression", /* T_Coexpr (18) */ "external block", /* T_External (19) */ "hash block", /* T_Slots (20) */ }; /* * Sizes of hash chain segments. * Table size must equal or exceed HSegs. */uword segsize[] = { ((uword)HSlots), /* segment 0 */ ((uword)HSlots), /* segment 1 */ ((uword)HSlots) * segment 2 */ ((uword)HSlots) << 2, /* segment 3 */ ((uword)HSlots) << 3, /* segment 4 */ ((uword)HSlots) << 4, /* segment 5 */ ((uword)HSlots) << 5, /* segment 6 */ ((uword)HSlots) << 6, /* segment 7 */ ((uword)HSlots) << 7, /* segment 8 */ ((uword)HSlots) << 8, /* segment 9 */ ((uword)HSlots) << 9, /* segment 10 */ ((uword)HSlots) << 10, /* segment 11 */ }; #ifdef FixedRegions#include "rmemfix.c"#else /* FixedRegions */#include "rmemexp.c"#endif /* FixedRegions *//* * alcblk - returns pointer to nbytes of free storage in block region. */static union block *alcblk(nbytes,tcode)uword nbytes;int tcode; { register uword fspace, *sloc; /* * See if there is enough room in the block region. */ fspace = DiffPtrs(blkend,blkfree); if (fspace < nbytes) syserr("block allocation botch"); /* * If monitoring, show the allocation. */ MMAlc((word)nbytes,tcode);#ifdef EvalTrace if (trfile) { fprintf(trfile,"a\t%ld\t%ld\t%d\t%ld\n",colmno,lineno,tcode,nbytes); }#endif /* EvalTrace */ /* * Decrement the free space in the block region by the number of bytes * allocated and return the address of the first byte of the allocated * block. */ sloc = (uword *)blkfree; blkneed -= nbytes; blkfree += nbytes; BlkType(sloc) = tcode; return (union block *)(sloc); } /* * alcreal - allocate a real value in the block region. */struct b_real *alcreal(val)double val; { register struct b_real *blk; blk = (struct b_real *)alcblk((uword)sizeof(struct b_real), T_Real);#ifdef Double/* access real values one word at a time */ { int *rp, *rq; rp = (word *) &(blk->realval); rq = (word *) &val; *rp++ = *rq++; *rp = *rq; }#else /* Double */ blk->realval = val;#endif /* Double */ return blk; } #ifdef LargeInts/* * alcbignum - allocate an n-digit bignum in the block region */struct b_bignum *alcbignum(n)word n; { register struct b_bignum *blk; register uword size; size = sizeof(struct b_bignum) + ((n - 1) * sizeof(DIGIT)); /* ensure whole number of words allocated */ size = (sizeize - 1) & -WordSize; blk = (struct b_bignum *)alcblk(size, T_Bignum); blk->blksize = size; blk->msd = blk->sign = 0; blk->lsd = n - 1; return blk; }#endif /* LargeInts */ /* * alccset - allocate a cset in the block region. */struct b_cset *alccset() { register struct b_cset *blk; register int i; blk = (struct b_cset *)alcblk((uword)sizeof(struct b_cset), T_Cset); blk->size = -1; /* flag size as not yet computed */ /* * Zero the bit array. */ for (i = 0; i < CsetSize; i++) blk->bits[i] = 0; return blk; } /* * alcfile - allocate a file block in the block region. */struct b_file *alcfile(fd, status, name)FILE *fd;int status;dptr name; { register struct b_file *blk; blk = (struct b_file *)alcblk((uword)sizeof(struct b_file), T_File); blk->fd = fd; blk->status = status; blk->fname = *name; return blk; } /* * alcrecd - allocate record with nflds fields in the block region. */struct b_record *alcrecd(nflds, recptr)int nflds;union block **recptr; { register struct b_record *blk; register int size; size = Vsizeof(struct b_record) + nflds*sizeof(struct descrip); blk = (struct b_record *)alcblk((uword)size, T_Record); blk->blksize = size; blk->recdesc = (union block *)recptr; return blk; } /* * alcextrnl - allocate an external block. */struct b_external *alcextrnl(n)int n; { register struct b_external *blk; blk = (struct b_external *)alcblk((uword)(n * sizeof(word)), T_External); blk->blksize = (n + 3) * sizeof(word); blk->descoff = 0; /* probably ought to clear the rest of the block */ return blk; } /* * alclist - allocate a list header block in the block region. */struct b_list *alclist(size)uword size; { static word list_ser = 1; register struct b_list *blk; blk = (struct b_list *)alcblk((uword)sizeof(struct b_list), T_List); blk->size = size; blk->listhead = NULL; blk->listtail = NULL; blk->id = list_ser++; return blk; } /* * alclstb - allocate a list element block in the block region. */struct b_lelem *alclstb(nslots, first, nused)uword nslots, first, nused; { register struct b_lelem *blk; register word i, size; size = Vsizeof(struct b_lelem) + nslots * sizeof(struct descrip); blk = (struct b_lelem *)alcblk((uword)size, T_Lelem); blk->blksize = size; blk->nslots = nslots; blk->first = first; blk->nused = nused; blk->listprev = NULL; blk->listnext = NULL; /* * Set all elements to &null. */ for (i = 0; i < nslots; i++) blk->lslots[i] = nulldesc; return blk; } /* * alchash - allocate a hashed structure (set or table header) in the block * region. */union block *alchash(tcode)int tcode; { static word table_ser = 1; static word set_ser = 1; register int i; register union block *blk; word serial; uword blksize; if (tcode == T_Table) { serial = table_ser++; blksize = sizeof(struct b_table); } else { /* tcode == T_Set */ serial = set_ser++; blksize = sizeof(struct b_set); } blk = alcblk(blksize, tcode); blk->set.size = 0; blk->set.id = serial; blk->set.mask = 0; for
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:rmemmg
+++++ Continued from previous card +++++
(i = 0; i < HSegs; i++) blk->set.hdir[i] = NULL; return blk; } /* * alcsegment - allocate a slot block in the block region. */struct b_slots *alcsegment(nslots)word nslots; { uword size; register struct b_slots *blk; size = sizeof(struct b_slots) + WordSize * (nslots - HSlots); blk = (struct b_slots *)alcblk(size, T_Slots); blk->blksize = size; while (--nslots >= 0) blk->hslots[nslots] = NULL; return blk; } /* * alctelem - allocate a table element block in the block region. */struct b_telem *alctelem() { register struct b_telem *blk; blk = (struct b_telem *)alcblk((uword)sizeof(struct b_telem), T_Telem); blk->hashnum = 0; blk->clink = NULL; blk->tref = nulldesc; blk->tval = nulldesc; return blk; } /* * alcselem - allocate a set element block. */struct b_selem *alcselem(mbr,hn)dptr mbr;uword hn; { register struct b_selem *blk; blk = (struct b_selem *)alcblk((uword)sizeof(struct b_selem), T_Selem); blk->clink = NULL; blk->setmem = *mbr; blk->hashnum = hn; return blk; } /* * alcsubs - allocate a substring trapped variable in the block region. */struct b_tvsubs *alcsubs(len, pos, var)word len, pos;dptr var; { register struct b_tvsubs *blk; blk = (struct b_tvsubs *)alcblk((uword)sizeof(struct b_tvsubs), T_Tvsubs); blk->sslen = len; blk->sspos = pos; blk->ssvar = *var; return blk; } /* * alctvtbl - allocate a table element trapped variable block in the block * region. */struct b_tvtbl *alctvtbl(tbl, ref, hashnum)register dptr tbl, ref;uword hashnum; { register struct b_tvtbl *blk; blk = (struct b_tvtbl *)alcblk((uword)sizeof(struct b_tvtbl), T_Tvtbl); blk->hashnum = hashnum; blk->clink = BlkLoc(*tbl); blk->tref = *ref; blk->tval = nulldesc; return blk; } /* * alcstr - allocate a string in the string space. */char *alcstr(s, slen)register char *s;register word slen; { register char *d; register uword fspace; char *ofree; MMStr(slen);#ifdef EvalTrace if (trfile) { fprintf(trfile,"a\t%ld\t%ld\t%ld\n",colmno,lineno,slen); }#endif /* EvalTrace */ /* * See if there is enough room in the string space. */ fspace = DiffPtrs(strend,strfree); if (fspace < slen) syserr("string allocation botch"); strneed -= slen; /* * Copy the string into the string space, saving a pointer to its * beginning. Note that s may be null, in which case the space * is still to be allocated but nothing is to be copied into it. */ ofree = d = strfree; if (s) { while (slen-- > 0) *d++ = *s++; } else d += slen; strfree = d; return ofree; } /* * alccoexp - allocate a co-expression stack block. */struct b_coexpr *alccoexp() { struct b_coexpr *ep; static word coexp_ser = 2; /* &main is 1 */#ifdef ATTM32 ep = (struct b_coexpr *)coexp_salloc(); /* 3B2/15/4000 stack */#else /* ATTM32 */ ep = (struct b_coexpr *)malloc((msize)stksize);#endif /* ATTM32 */ /* * If malloc failed or if there have been too many co-expression allocations * since a collection, attempt to free some co-expression blocks and retry. */#ifdef FixedRegions if (ep == NULL || alcnum > AlcMax) {#else /* FixedRegions */ if (ep == NULL) {#endif /* Fixed Regions */ collect(Static);#ifdef ATTM32 /* not needed, but here to play it safe */ ep = (struct b_coexpr *)coexp_salloc(); /* 3B2/15/4000 stack */#else /* ATTM32 */ ep = (struct b_coexpr *)malloc((msize)stksize);#endif /* ATTM32 */ } if (ep == NULL) { k_errornumber = -305; k_errortext = ""; k_errorvalue = nulldesc; return NULL; }#ifdef FixedRegions alcnum++; /* increment allocation count since last g.c. */#endif /* FixedRegions */ ep->title = T_Coexpr; ep->es_actstk = NULL; ep->size = 0; ep->id = coexp_ser++; ep->nextstk = stklist; stklist = ep; MMStat((char *)ep, stksize, 'X'); return ep; } /* * alcactiv - allocate a co-expression activation block. */struct astkblk *alcactiv() { struct astkblk *abp; abp = (struct astkblk *)malloc((msize)sizeof(struct astkblk));#ifdef FixedRegions /* * If malloc failed, attempt to free some co-expression blocks and retry. */ if (abp == NULL) { collect(Static); abp = (struct astkblk *)malloc((msize)sizeof(struct astkblk)); }#endif /* FixedRegions */ if (abp == NULL) { k_errornumber = -305; k_errortext = ""; k_errorvalue = nulldesc; return NULL; } abp->nactivators = 0; abp->astk_nxt = NULL; return abp; } /* * alcrefresh - allocate a co-expression refresh block. */struct b_refresh *alcrefresh(entryx, na, nl)word *entryx;int na, nl; { int size; struct b_refresh *blk; size = Vsizeof(struct b_refresh) + (na + nl) * sizeof(struct descrip); blk = (struct b_refresh *)alcblk((uword)size, T_Refresh); blk->blksize = size; blk->ep = entryx; blk->numlocals = nl; return blk; } /* * blkreq - insure that at least bytes of space are left in the block region. * The amount of space needed is transmitted to the collector via * the global variable blkneed. */int blkreq(bytes)uword bytes; { blkneed = bytes; if (bytes > (uword)DiffPtrs(blkend,blkfree)) { coll_blk++; collect(Blocks); if (bytes > (uword)DiffPtrs(blkend,blkfree)) RetError(-307, nulldesc); } return Success; } /* * strreq - insure that at least n of space are left in the string * space. The amount of space needed is transmitted to the collector * via the global variable strneed. */int strreq(n)uword n; { strneed = n; /* save in case of collection */ if (n > (uword)DiffPtrs(strend,strfree)) { coll_str++; collect(Strings); if (n > (uword)DiffPtrs(strend,strfree)) {#ifdef FixedRegions if (qualfail) RetError(-304, nulldesc);#endif /* FixedRegions */ RetError(-306, nulldesc); } } return Success; } /* * cofree - collect co-expression blocks. This is done after * the marking phase of garbage collection and the stacks that are * reachable have pointers to data blocks, rather than T_Coexpr, * in their type field. */novalue cofree() { register struct b_coexpr **ep, *xep; extern word mstksize; /* main stack size */ register struct astkblk *abp, *xabp; /* * Reset the type for &main. */ BlkLoc(k_main)->coexpr.title = T_Coexpr; /* * The co-expression blocks are linked together through their * nextstk fields, with stklist pointing to the head of the list. * The list is traversed and each stack that was not marked * is freed. */ ep = &stklist; while (*ep != NULL) { if (BlkType(*ep) == T_Coexpr) { xep = *ep; *ep = (*ep)->nextstk; /* * Free the astkblks. There should always be one and it seems that * it's not possible to have more than one, but nonetheless, the * code provides for more than one. */ for (abp = xep->es_actstk; abp; ) { xabp = abp; abp = abp->astk_nxt; free((pointer)xabp); } free((pointer)xep); } else { BlkType(*ep) = T_Coexpr; MMStat((char *)(*ep), stksize, 'X'); ep = &(*ep)->nextstk; } } MMStat((char *)stack, mstksize, 'X'); /* Also record main stack */ } /* * collect - do a garbage collection. */novalue collect(region)int region; { register dptr dp; struct b_coexpr *cp; MMBGC(region);#ifdef EvalTrace if (trfile) { fprintf(trfile,"c\t%ld\t%ld\t%d\n",colmno,lineno,region); }#endif /* EvalTrace */ coll_tot++;#ifdef FixedRegions alcnum = 0;#endif /* FixedRegions */ /* * Garbage collection cannot be done until initialization is complete. */ if (sp == NULL) return;#if MACINTOSH#if MPW SetCursor(*GetCursor(watchCursor)); /* Set watch cursor */#endif /* MPW */#endif /* MACINTOSH */ /* * Sync the values (used by sweep) in the coexpr block for ¤t * with the current values. */ cp = (struct b_coexpr *)BlkLoc(k_current); cp->es_pfp = pfp; cp->es_gfp = gfp; cp->es_efp = efp; cp->es_sp = sp; /* * Reset qualifier list. */#ifndef FixedRegions quallist = (dptr *)blkfree;#endif /* FixedRegions */ qualfree = quallist; qualfail = 0; /* * Mark the stacks for &main and the current co-expression. */ markblock(&k_main); markblock(&k_current); /* * Mark &subject and the cached s2 and s3 strings for map. */ postqual(&k_subject); if (Qual(maps2)) /* caution: the cached arguments of */ postqual(&maps2); /* map may not be strings. */ else if (Pointer(maps2)) markblock(&maps2); if (Qual(maps3)) postqual(&maps3); else if (Pointer(maps3)) markblock(&maps3); /* * Mark the tended descriptors and the global and static variables. */ for (dp = &tended[1]; dp <= &tended[ntended]; dp++) if (Qual(*dp)) postqual(dp); else if (Pointer(*dp)) markblock(dp); for (dp = globals; dp < eglobals; dp++) if (Qual(*dp)) postqual(dp); else if (Pointer(*dp)) markblock(dp); for (dp = statics; dp < estatics; dp++) if (Qual(*dp)) postqual(dp); else if (Pointer(*dp)) markblock(dp); reclaim(region); MMEGC();#ifndef FixedRegions if (qualfail && (region == Strings || statneed) && DiffPtrs((char *)quallist,blkfree) > Sqlinc) /* * The string region could not be collected, but it looks like it * needs to be. Collecting the block region gave more room for * the qualifier list, so try again. */ collect(region);#endif /* FixedRegions */ } /* * markblock - mark each accessible block in the block region and build * back-list of descriptors pointing to that block. (Phase I of garbage * collection.) */novalue markblock(dp)dptr dp; { register dptr dp1; register char *block, *endblock; word type, fdesc; int numptr; register union block **ptr, **lastptr; /* * Get the block to which dp points. */ block = (char *)BlkLoc(*dp); if (InRange(blkbase,block,blkfree)) { if (Var(*dp) && !Tvar(*dp)) { /* * The descriptor is a variable; block now points to the head of the * block containing the descriptor. */ if (Offset(*dp) == 0) return; } type = BlkType(block); if ((uword)type <= MaxType) { /* * The type is valid, which indicates that this block has not * been marked. Point endblock to the byte past the end * of the block. */ endblock = block + BlkSize(block); MMMark(block,(int)type); } /* * Add dp to the back chain for the block and point the * block (via the type field) to dp.vword. */ BlkLoc(*dp) = (union block *)type; BlkType(block) = (uword)&BlkLoc(*dp); if ((unsigned int)type <= MaxType) { /* * The block was not marked; process pointers and descriptors * within the block. */ if ((fdesc = firstp[type]) > 0) { /* * The block contains pointers; mark each pointer. */ ptr = (union block **)(block + fdesc); numptr = ptrno[type]; if (numptr > 0) lastptr = ptr + numptr; else lastptr = (union block **)endblock; for (; ptr < lastptr; ptr++) if (*ptr != NULL) markptr(ptr); } if ((fdesc = firstd[type]) > 0) /* * The block contains descriptors; mark each descriptor. */ for (dp1 = (dptr)(block + fdesc); (char *)dp1 < endblock; dp1++) { if (Qual(*dp1)) postqual(dp1); else if (Pointer(*dp1)) markblock(dp1); } } } else if (dp->dword == D_Coexpr && (unsigned int)BlkType(block) <= MaxType) { struct b_coexpr *cp; struct astkblk *abp; int i; struct descrip adesc; /* * dp points to a co-expression block that has not been * marked. Point the block to dp. Sweep the interpreter * stack in the block. Then mark the block for the * activating co-expression and the refresh block. */ BlkType(block) = (uword)dp; sweep((struct b_coexpr *)block);#ifdef Coexpr /* * Mark the activators of this co-expression. The activators are * stored as a list of addresses, but markblock requires the address * of a descriptor. To accommodate markblock, the dummy descriptor * adesc is filled in with each activator address in turn and then * marked. Since co-expressions and the descriptors that reference * them don't participate in the back-chaining scheme, it's ok to * reuse the descriptor in this manner. */ cp = (struct b_coexpr *)block; adesc.dword = D_Coexpr; for (abp = cp->es_actstk; abp != NULL; abp = abp->astk_nxt) { for (i = 1; i <= abp->nactivators; i++) { BlkLoc(adesc) = (union block *)abp->arec[i-1].activator; markblock(&adesc); } } markblock(&((struct b_coexpr *)block)->freshblk);#endif /* Coexpr */ } } /* * markptr - just like mark block except the object pointing at the block * is just a block pointer, not a descriptor. */novalue markptr(ptr)union block **ptr; { register dptr dp; register char *block, *endblock; word type, fdesc; int numptr; register union block **ptr1, **lastptr; /* * Get the block to which ptr points. */ block = (char *)*ptr; if (InRange(blkbase,block,blkfree)) { type = BlkType(block); if ((uword)type <= MaxType) { /* * The type is valid, which indicates that this block has not * been marked. Point endblock to the byte past the end * of the block. */ endblock = block + BlkSize(block); MMMark(block,(int)type); } /* * Add ptr to the back chain for the block and point the * block (via the type field) to ptr. */ *ptr = (union block *)type; BlkType(block) = (uword)ptr; if ((unsigned int)type <= MaxType) { /* * The block was not marked; process pointers and descriptors * within the block. */ if ((fdesc = firstp[type]) > 0) { /* * The block contains pointers; mark each pointer. */ ptr1 = (union block **)(block + fdesc); numptr = ptrno[type]; if (numptr > 0) lastptr = ptr1 + numptr; else l
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:rmemmg
+++++ Continued from previous card +++++
astptr = (union block **)endblock; for (; ptr1 < lastptr; ptr1++) if (*ptr1 != NULL) markptr(ptr1); } if ((fdesc = firstd[type]) > 0) /* * The block contains descriptors; mark each descriptor. */ for (dp = (dptr)(block + fdesc); (char *)dp < endblock; dp++) { if (Qual(*dp)) postqual(dp); else if (Pointer(*dp)) markblock(dp); } } } } /* * adjust - adjust pointers into the block region, beginning with block oblk * and basing the "new" block region at nblk. (Phase II of garbage * collection.) */novalue adjust(source,dest)char *source, *dest; { register union block **nxtptr, **tptr; /* * Loop through to the end of allocated block region, moving source * to each block in turn and using the size of a block to find the * next block. */ while (source < blkfree) { if ((uword)(nxtptr = (union block **)BlkType(source)) > MaxType) { /* * The type field of source is a back pointer. Traverse the * chain of back pointers, changing each block location from * source to dest. */ while ((uword)nxtptr > MaxType) { tptr = nxtptr; nxtptr = (union block **) *nxtptr; *tptr = (union block *)dest; } BlkType(source) = (uword)nxtptr | F_Mark; dest += BlkSize(source); } source += BlkSize(source); } } /* * compact - compact good blocks in the block region. (Phase III of garbage * collection.) */novalue compact(source)char *source; { register char *dest; register word size; /* * Start dest at source. */ dest = source; /* * Loop through to end of allocated block space, moving source * to each block in turn, using the size of a block to find the next * block. If a block has been marked, it is copied to the * location pointed to by dest and dest is pointed past the end * of the block, which is the location to place the next saved * block. Marks are removed from the saved blocks. */ while (source < blkfree) { size = BlkSize(source); if (BlkType(source) & F_Mark) { BlkType(source) &= ~F_Mark; if (source != dest) mvc((uword)size,source,dest); dest += size; } source += size; } /* * dest is the location of the next free block. Now that compaction * is complete, point blkfree to that location. */ blkfree = dest; } /* * postqual - mark a string qualifier. Strings outside the string space * are ignored. */novalue postqual(dp)dptr dp; { char *newend; if (InRange(strbase,StrLoc(*dp),strend)) { /* * The string is in the string space. Add it to the string qualifier * list, but before adding it, expand the string qualifier list if * necessary. */ if (qualfree >= equallist) {#ifdef FixedRegions qualfail = 1; return;#else /* FixedRegions */ newend = (char *)equallist + Sqlinc; /* * Make sure region has not changed and that it can be expanded. */ if (currend != sbrk((word)0) || (int)brk((char *)newend) == -1) { qualfail = 1; return; } equallist = (dptr *)newend; currend = sbrk((word)0);#ifdef QuallistExp fprintf(stderr,"size of quallist = %ld\n", (long)DiffPtrs((char *)equallist,(char *)quallist)); fflush(stderr);#endif /* QuallistExp */#endif /* FixedRegions */ } *qualfree++ = dp; } } /* * scollect - collect the string space. quallist is a list of pointers to * descriptors for all the reachable strings in the string space. For * ease of description, it is referred to as if it were composed of * descriptors rather than pointers to them. */novalue scollect(extra)word extra; { register char *source, *dest; register dptr *qptr; char *cend; if (qualfree <= quallist) { /* * There are no accessible strings. Thus, there are none to * collect and the whole string space is free. */ strfree = strbase; return; } /* * Sort the pointers on quallist in ascending order of string * locations. */ qsort((char *)quallist, (int)(DiffPtrs((char *)qualfree,(char *)quallist)) / sizeof(dptr *), sizeof(dptr), qlcmp); /* * The string qualifiers are now ordered by starting location. */ dest = strbase; source = cend = StrLoc(**quallist); /* * Loop through qualifiers for accessible strings. */ for (qptr = quallist; qptr < qualfree; qptr++) { if (StrLoc(**qptr) > cend) { /* * qptr points to a qualifier for a string in the next clump. * The last clump is moved, and source and cend are set for * the next clump. */ MMSMark(source,DiffPtrs(cend,source)); while (source < cend) *dest++ = *source++; source = cend = StrLoc(**qptr); } if ((StrLoc(**qptr) + StrLen(**qptr)) > cend) /* * qptr is a qualifier for a string in this clump; extend * the clump. */ cend = StrLoc(**qptr) + StrLen(**qptr); /* * Relocate the string qualifier. */ StrLoc(**qptr) = StrLoc(**qptr) + DiffPtrs(dest,source) + (uword)extra; } /* * Move the last clump. */ MMSMark(source,DiffPtrs(cend,source)); while (source < cend) *dest++ = *source++; strfree = dest; } /* * qlcmp - compare the location fields of two string qualifiers for qsort. */int qlcmp(q1,q2)dptr *q1, *q2; {#if IntBits == 16 long l; l = (long)(DiffPtrs(StrLoc(**q1),StrLoc(**q2))); if (l < 0) return -1; else if (l > 0) return 1; else return 0;#else /* IntBits = 16 */ return (int)(DiffPtrs(StrLoc(**q1),StrLoc(**q2)));#endif /* IntBits == 16 */ } /* * mvc - move n bytes from src to dest * * The algorithm is to copy the data (using memcopy) in the largest * chunks possible, which is the size of area of the source data not in * the destination area (ie non-overlapped area). (Chunks are expected to * be fairly large.) */novalue mvc(n, src, dest)uword n;register char *src, *dest; { register char *srcend, *destend; /* end of data areas */ word copy_size; /* of size copy_size */ word left_over; /* size of last chunk < copy_size */ if (n == 0) return; srcend = src + n; /* point at byte after src data */ destend = dest + n; /* point at byte after dest area */ if ((destend <= src) || (srcend <= dest)) /* not overlapping */ memcopy(dest,src,n); else { /* overlapping data areas */ if (dest < src) { /* * The move is from higher memory to lower memory. */ copy_size = DiffPtrs(src,dest); /* now loop round copying copy_size chunks of data */ do { memcopy(dest,src,copy_size); dest = src; src = src + copy_size; } while (DiffPtrs(srcend,src) > copy_size); left_over = DiffPtrs(srcend,src); /* copy final fragment of data - if there is one */ if (left_over > 0) memcopy(dest,src,left_over); } else if (dest > src) { /* * The move is from lower memory to higher memory. */ copy_size = DiffPtrs(destend,srcend); /* now loop round copying copy_size chunks of data */ do { destend = srcend; srcend = srcend - copy_size; memcopy(destend,srcend,copy_size); } while (DiffPtrs(srcend,src) > copy_size); left_over = DiffPtrs(srcend,src); /* copy intial fragment of data - if there is one */ if (left_over > 0) memcopy(dest,src,left_over); } } /* end of overlapping data area code */ /* * Note that src == dest implies no action */ } /* * sweep - sweep the stack, marking all descriptors there. Method * is to start at a known point, specifically, the frame that the * fp points to, and then trace back along the stack looking for * descriptors and local variables, marking them when they are found. * The sp starts at the first frame, and then is moved down through * the stack. Procedure, generator, and expression frames are * recognized when the sp is a certain distance from the fp, gfp, * and efp respectively. * * Sweeping problems can be manifested in a variety of ways due to * the "if it can't be identified it's a descriptor" methodology. */novalue sweep(ce)struct b_coexpr *ce; { register word *s_sp; register struct pf_marker *fp; register struct gf_marker *s_gfp; register struct ef_marker *s_efp; word nargs, type, gsize; fp = ce->es_pfp; s_gfp = ce->es_gfp; if (s_gfp != 0) { type = s_gfp->gf_gentype; if (type == G_Psusp) gsize = Wsizeof(*s_gfp); else gsize = Wsizeof(struct gf_smallmarker); } s_efp = ce->es_efp; s_sp = ce->es_sp; nargs = 0; /* Nargs counter is 0 initially. */ while ((fp != 0 || nargs)) { /* Keep gil current fp is 0 and no arguments are left. */ if (s_sp == (word *)fp + Vwsizeof(*pfp) - 1) { /* sp has reached the upper boundary of a procedure frame, process the frame. */ s_efp = fp->pf_efp; /* Get saved efp out of frame */ s_gfp = fp->pf_gfp; /* Get save gfp */ if (s_gfp != 0) { type = s_gfp->gf_gentype; if (type == G_Psusp) gsize = Wsizeof(*s_gfp); else gsize = Wsizeof(struct gf_smallmarker); } s_sp = (word *)fp - 1; /* First argument descriptor is first word above proc frame */ nargs = fp->pf_nargs; fp = fp->pf_pfp; } else if (s_gfp != NULL && s_sp == (word *)s_gfp + gsize - 1) { /* The sp has reached the lower end of a generator frame, process the frame.*/ if (type == G_Psusp) fp = s_gfp->gf_pfp; s_sp = (word *)s_gfp - 1; s_efp = s_gfp->gf_efp; s_gfp = s_gfp->gf_gfp; if (s_gfp != 0) { type = s_gfp->gf_gentype; if (type == G_Psusp) gsize = Wsizeof(*s_gfp); else gsize = Wsizeof(struct gf_smallmarker); } nargs = 1; } else if (s_sp == (word *)s_efp + Wsizeof(*s_efp) - 1) { /* The sp has reached the upper end of an expression frame, process the frame. */ s_gfp = s_efp->ef_gfp; /* Restore gfp, */ if (s_gfp != 0) { type = s_gfp->gf_gentype; if (type == G_Psusp) gsize = Wsizeof(*s_gfp); else gsize = Wsizeof(struct gf_smallmarker); } s_efp = s_efp->ef_efp; /* and efp from frame. */ s_sp -= Wsizeof(*s_efp); /* Move past expression frame marker. */ } else { /* Assume the sp is pointing at a descriptor. */ if (Qual(*((dptr)(&s_sp[-1])))) postqual((dptr)&s_sp[-1]); else if (Pointer(*((dptr)(&s_sp[-1])))) markblock((dptr)&s_sp[-1]); s_sp -= 2; /* Move past descriptor. */ if (nargs) /* Decrement argument count if in an*/ nargs--; /* argument list. */ } } } #ifdef DeBugIconx/* * descr - dump a descriptor. Used only for debugging. */novalue descr(dp)dptr dp; { int i; fprintf(stderr,"%08lx: ",(long)dp); if (Qual(*dp)) fprintf(stderr,"%15s","qualifier"); else if (Var(*dp) && !Tvar(*dp)) fprintf(stderr,"%15s","variable"); else { i = Type(*dp); switch (i) { case T_Null: fprintf(stderr,"%15s","null"); break; case T_Integer: fprintf(stderr,"%15s","integer"); break; default: fprintf(stderr,"%15s",blkname[i]); } } fprintf(stderr," %08lx %08lx\n",(long)dp->dword,(long)IntVal(*dp)); } /* * blkdump - dump the allocated block region. Used only for debugging. */novalue blkdump() { register char *blk; register word type, size, fdesc; register dptr ndesc; fprintf(stderr, "\nDump of allocated block region. base:%08lx free:%08lx max:%08lx\n", (long)blkbase,(long)blkfree,(long)blkend); fprintf(stderr," loc type size contents\n"); for (blk = blkbase; blk < blkfree; blk += BlkSize(blk)) { type = BlkType(blk); size = BlkSize(blk); fprintf(stderr," %08lx %15s %4ld\n",(long)blk,blkname[type], (long)size); if ((fdesc = firstd[type]) > 0) for (ndesc = (dptr)(blk + fdesc); ndesc < (dptr)(blk + size); ndesc++) { fprintf(stderr," "); descr(ndesc); } fprintf(stderr,"\n"); } fprintf(stderr,"end of block region.\n"); }#endif /* DeBugIconx */ :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:rmisc.c
/* * File: rmisc.c * Contents: deref, eq, [gcvt], getvar, hash, outimage, [qsort], * qtos, trace, pushact, popact, topact, [dumpact], putpos, putsub, putint, * findline, findipc, findfile, [llqsort], doimage, prescan, getimage * printable. * * Integer overflow checking. */#ifdef IconAlloc#define free mem_free#endif /* IconAlloc */#include <math.h>#include "::h:config.h"#include "::h:rt.h"#include "rproto.h"#include <ctype.h>/* * Prototypes. */hidden novalue listimage Params((FILE *f,struct b_list *lp, int restrict));hidden novalue printimage Params((FILE *f,int c,int q));#ifdef IconQsorthidden novalue qswap Params((char *a, char *b, int w));#endif /* IconQsort */hidden novalue showlevel Params((int n));hidden novalue showline Params((char *f,int l)); /* * deref - dereference a descriptor. */int deref(dp)dptr dp; { register uword hn; register union block *bp; struct descrip v, tref; union block *tbl; if (!Tvar(*dp)) /* * An ordinary variable is being dereferenced; just replace * *dp with the descriptor *dp is pointing to. */ *dp = *(dptr)((word *)VarLoc(*dp) + Offset(*dp)); else switch (Type(*dp)) { case T_Tvsubs: /* * A substring trapped variable is being dereferenced. * Point bp to the trapped variable block and v to * the string. */ bp = TvarLoc(*dp); v = bp->tvsubs.ssvar; if (DeRef(v) == Error) return Error; if (!Qual(v)) RetError(103, v); if (bp->tvsubs.sspos + bp->tvsubs.sslen - 1 > StrLen(v)) RetError(-205, nulldesc); /* * Make a descriptor for the substring by getting the * length and pointing into the string. */ StrLen(*dp) = bp->tvsubs.sslen; StrLoc(*dp) = StrLoc(v) + bp->tvsubs.sspos - 1; break; case T_Tvtbl: if (BlkLoc(*dp)->tvtbl.title == T_Telem) { /* * The tvtbl has been converted to a telem and is * in the table. Replace the descriptor pointed to * by dp with the value of the element. */ *dp = BlkLoc(*dp)->telem.tval; break; } /* * Point tbl to the table header block, tref to the * subscripting value, and bp to the appropriate * chain. Point dp to a descriptor for the default * value in case the value referenced by the subscript * is not in the table. */ tbl = BlkLoc(*dp)->tvtbl.clink; tref = BlkLoc(*dp)->tvtbl.tref; hn = BlkLoc(*dp)->tvtbl.hashnum; *dp = tbl->table.defvalue; bp = *(hchain((union block *)tbl, hn)); /* * Traverse the element chain looking for the subscript * value. If found, replace the descriptor pointed to * by dp with the value of the element. */ while (bp != NULL && bp->telem.hashnum <= hn) { if ((bp->telem.hashnum == hn) && (equiv(&bp->telem.tref, &tref))) { *dp = bp->telem.tval; break; } bp = bp->telem.clink; } break; case T_Tvkywd: bp = TvarLoc(*dp); *dp = bp->tvkywd.kyval; break; default: syserr("deref: illegal trapped variable"); }#ifdef DeBugIconx if (Var(*dp)) syserr("deref: didn't get dereferenced");#endif /* DeBugIconx */ return Success; } #ifdef IconGcvt/* * gcvt - Convert number to a string in buf. If possible, ndigit * significant digits are produced, otherwise a form with an exponent is used. * * The name is actually #defined as "icon_gcvt" in config.h. */char *gcvt(number, ndigit, buf)double number;int ndigit;char *buf; { int sign, decpt; register char *p1, *p2; register i; p1 = ecvt(number, ndigit, &decpt, &sign); p2 = buf; if (sign) *p2++ = '-'; for (i=ndigit-1; i>0 && p1[i]=='0'; i--) ndigit--; if (decpt >= 0 && decpt-ndigit > 4 || decpt < 0 && decpt < -3) { /* use E-style */ decpt--; *p2++ = *p1++; *p2++ = '.'; for (i=1; i<ndigit; i++) *p2++ = *p1++; *p2++ = 'e'; if (decpt<0) { decpt = -decpt; *p2++ = '-'; } else *p2++ = '+'; if (decpt/100 > 0) *p2++ = decpt/100 + '0'; if (decpt/10 > 0) *p2++ = (decpt%100)/10 + '0'; *p2++ = decpt%10 + '0'; } else { if (decpt<=0) { /* if (*p1!='0') */ *p2++ = '0'; *p2++ = '.'; while (decpt<0) { decpt++; *p2++ = '0'; } } for (i=1; i<=ndigit; i++) { *p2++ = *p1++; if (i==decpt) *p2++ = '.'; } if (ndigit<decpt) { while (ndigit++<decpt) *p2++ = '0'; *p2++ = '.'; } } if (p2[-1]=='.') *p2++ = '0'; *p2 = '\0'; return(buf); }#endif /* IconGcvt */ /* * Get variable descriptor from name. */int getvar(s,vp) char *s; dptr vp; { register dptr dp; register dptr np; register int i; struct b_proc *bp; struct pf_marker *fp = pfp;/* * Is it a keyword that's a variable? */ if (*s == '&') { if (strcmp(s,"&error") == 0) { /* must put basic one first */ vp->dword = D_Tvkywd; VarLoc(*vp) = (dptr)&tvky_err; return Success; } else if (strcmp(s,"&pos") == 0) { vp->dword = D_Tvkywd; VarLoc(*vp) = (dptr)&tvky_pos; return Success; } else if (strcmp(s,"&random") == 0) { vp->dword = D_Tvkywd; VarLoc(*vp) = (dptr)&tvky_ran; return Success; } else if (strcmp(s,"&subject") == 0) { vp->dword = D_Tvkywd; VarLoc(*vp) = (dptr)&tvky_sub; return Success; } else if (strcmp(s,"&trace") == 0) { vp->dword = D_Tvkywd; VarLoc(*vp) = (dptr)&tvky_trc; return Success; } else return Failure; }/* * Look for the variable with the name of the local identifiers, * parameters, and static names in each Icon procedure frame on the stack. * If not found among the locals, check the global variables. * If a variable with name is found, variable() returns a variable * descriptor that points to the corresponding value descriptor. * If no such variable exits, it fails. */ /* * If no procedure has been called (as can happen with icon_call(), * dont' try to find local identifier. */ if (pfp == NULL) goto glbvars; dp = argp; bp = (struct b_proc *)BlkLoc(*dp); /* get address of procedure block */ np = bp->lnames; /* Check the formal parameter names. */ for (i = abs((int)bp->nparam); i > 0; i--) { dp++; if (strcmp(s,StrLoc(*np)) == 0) { vp->dword = D_Var; VarLoc(*vp) = (dptr)dp; return Success; } np++; } dp = &fp->pf_locals[0]; for (i = (int)bp->ndynam; i > 0; i--) { /* Check the local dynamic names. */ if (strcmp(s,StrLoc(*np)) == 0) { vp->dword = D_Var; VarLoc(*vp) = (dptr)dp; return Success; } np++; dp++; } dp = &statics[bp->fstatic]; /* Check the local static names. */ for (i = (int)bp->nstatic; i > 0; i--) { if (strcmp(s,StrLoc(*np)) == 0) { vp->dword = D_Var; VarLoc(*vp) = (dptr)dp; return Success; } np++; dp++; }glbvars: dp = globals; /* Check the global variable names. */ np = gnames; while (dp < eglobals) { if (strcmp(s,StrLoc(*np)) == 0) { vp->dword = D_Var; VarLoc(*vp) = (dptr)(dp); return Success; } np++; dp++; } return Failure;} /* * hash - compute hash value of arbitrary object for table and set accessing. */uword hash(dp)dptr dp; { register char *s; register uword i; register word j, n; register int *bitarr; double r; if (Qual(*dp)) { /* * Compute the hash value for the string based on a scaled sum * of its first ten characters, plus its length. */ i = 0; s = StrLoc(*dp); j = n = StrLen(*dp); if (j > 10) /* limit scan to first ten characters */ j = 10; while (j-- > 0) { i += *s++ & 0xFF; /* add unsigned version of next char */ i *= 39; /* scale total by a nice prime number */ } i += n; /* add the (untruncated) string length */ } else { switch (Type(*dp)) { /* * The hash value of an integer is itself times eight times the golden * ratio. We do this calculation in fixed point. We don't just use * the integer itself, for that would give bad results with sets * having entries that are multiples of a power of two. */ case T_Integer: i = (13255 * (uword)IntVal(*dp)) >> 10; break;#ifdef LargeInts /* * The hash value of a bignum is based on its length and its * most and least significant digits. */ case T_Bignum: { struct b_bignum *b = &BlkLoc(*dp)->bignumblk; i = ((b->lsd - b->msd) << 16) ^ (b->digits[b->msd] << 8) ^ b->digits[b->lsd]; } break;#endif /* LargeInts */ /* * The hash value of a real number is itself times a constant, * converted to an unsigned integer. The intent is to scramble * the bits well, in the case of integral values, and to scale up * fractional values so they don't all land in the same bin. * The constant below is 32749 / 29, the quotient of two primes, * and was observed to work well in empirical testing. */ case T_Real: GetReal(dp,r); i = r * 1129.27586206896558; break; /* * The hash value of a cset is based on a convoluted combination * of all its bits. */ case T_Cset: i = 0; bitarr = BlkLoc(*dp)->cset.bits + CsetSize - 1; for (j = 0; j < CsetSize; j++) { i += *bitarr--; i *= 37; /* better distribution */ } i %= 1048583; /* scramble the bits */ break; /* * The hash value of a list, set, table, or record is its id, * hashed like an integer. */ case T_List: i = (13255 * BlkLoc(*dp)->list.id) >> 10; break; case T_Set: i = (13255 * BlkLoc(*dp)->set.id) >> 10; break; case T_Table: i = (13255 * BlkLoc(*dp)->table.id) >> 10; break; case T_Record: i = (13255 * BlkLoc(*dp)->record.id) >> 10; break; default: /* * For other types, use the type code as the hash * value. */ i = Type(*dp); break; } } return i; } #define StringLimit 16 /* limit on length of imaged string */#define ListLimit 6 /* limit on list items in image *//* * outimage - print image of *dp on file f. If restrict is nonzero, * fields of records will not be imaged. */novalue outimage(f, dp, restrict)FILE *f;dptr dp;int restrict; { register word i, j; register char *s; register union block *bp, *vp; char *type; FILE *fd; struct descrip q; extern char *blkname[]; double rresult;outimg: if (Qual(*dp)) { /* * *dp is a string qualifier. Print StringLimit characters of it * using printimage and denote the presence of additional characters * by terminating the string with "...". */ i = StrLen(*dp); s = StrLoc(*dp); j = Min(i, StringLimit); putc('"', f); while (j-- > 0) printimage(f, *s++, '"'); if (i > StringLimit) fprintf(f, "..."); putc('"', f); return; } if (Var(*dp) && !Tvar(*dp)) { /* * *d is a variable. Print "variable =", dereference it, and * call outimage to handle the value. */ fprintf(f, "(variable = "); dp = (dptr)((word *)VarLoc(*dp) + Offset(*dp)); outimage(f, dp, restrict); putc(')', f); return; } switch (Type(*dp)) { case T_Null: fprintf(f, "&null"); return; case T_Integer: fprintf(f, "%ld", (long)IntVal(*dp)); return;#ifdef LargeInts case T_Bignum: bigprint(f, dp); return;#endif /* LargeInts */ case T_Real: { char s[30]; struct descrip rd; GetReal(dp,rresult); rtos(rresult, &rd, s); fprintf(f, "%s", StrLoc(rd)); return; } case T_Cset: /* * Check for distinguished csets by looking at the address of * of the object to image. If one is found, print its name. */ if ((char *)BlkLoc(*dp) == (char *)&k_ascii) { fprintf(f, "&ascii"); return; } else if ((char *)BlkLoc(*dp) == (char *)&k_cset) { fprintf(f, "&cset"); return; } else if ((char *)BlkLoc(*dp) == (char *)&k_digits) { fprintf(f, "&digits"); return; } else if ((char *)BlkLoc(*dp) == (char *)&k_lcase) { fprintf(f, "&lcase"); return; } else if ((char *)BlkLoc(*dp) == (char *)&k_letters) { fprintf(f, "&letters"); return; } else if ((char *)BlkLoc(*dp) == (char *)&k_ucase) { fprintf(f, "&ucase"); return; } /* * Use printimage to print each character in the cset. Follow * with "..." if the cset contains more than StringLimit * characters. */ putc('\'', f); j = StringLimit; for (i = 0; i < 256; i++) { if (Testb(i, BlkLoc(*dp)->cset.bits)) { if (j-- <= 0) { fprintf(f, "..."); break; } printimage(f, (int)i, '\''); } } putc('\'', f); return; case T_File: /* * Check for distinguished files by looking at the address of * of the object to image. If one is found, print its name. */ if ((fd = BlkLoc(*dp)->file.fd) == stdin) fprintf(f, "&input"); else if (fd == stdout) fprintf(f, "&output"); else if (fd == stderr) fprintf(f, "&errout"); else { /* * The file isn't a special one, just print "file(name)". */ i = StrLen(BlkLoc(*dp)->file.fname); s = StrLoc(BlkLoc(*dp)->file.fname); fprintf(f, "file("); while (i-- > 0) printimage(f, *s++, '\0'); putc(')', f); } return; case T_Proc: /* * Produce one of: * "procedure name" * "function name" * "record constructor name" * * Note tha
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:rmisc.
+++++ Continued from previous card +++++
t the number of dynamic locals is used to determine * what type of "procedure" is at hand. */ i = StrLen(BlkLoc(*dp)->proc.pname); s = StrLoc(BlkLoc(*dp)->proc.pname); switch ((int)BlkLoc(*dp)->proc.ndynam) { default: type = "procedure"; break; case -1: type = "function"; break; case -2: type = "record constructor"; break; } fprintf(f, "%s ", type); while (i-- > 0) printimage(f, *s++, '\0'); return; case T_List: /* * listimage does the work for lists. */ listimage(f, (struct b_list *)BlkLoc(*dp), restrict); return; case T_Table: /* * Print "table_m(n)" where n is the size of the table. */ fprintf(f, "table_%ld(%ld)", (long)BlkLoc(*dp)->table.id, (long)BlkLoc(*dp)->table.size); return; case T_Set: /* * print "set_m(n)" where n is the cardinality of the set */ fprintf(f,"set_%ld(%ld)",(long)BlkLoc(*dp)->set.id, (long)BlkLoc(*dp)->set.size); return; case T_Record: /* * If restrict is nonzero, print "record(n)" where n is the * number of fields in the record. If restrict is zero, print * the image of each field instead of the number of fields. */ bp = BlkLoc(*dp); i = StrLen(bp->record.recdesc->proc.recname); s = StrLoc(bp->record.recdesc->proc.recname); fprintf(f, "record "); while (i-- > 0) printimage(f, *s++, '\0'); fprintf(f, "_%ld", bp->record.id); j = bp->record.recdesc->proc.nfields; if (j <= 0) fprintf(f, "()"); else if (restrict > 0) fprintf(f, "(%ld)", (long)j); else { putc('(', f); i = 0; for (;;) { outimage(f, &bp->record.fields[i], restrict+1); if (++i >= j) break; putc(',', f); } putc(')', f); } return; case T_Tvsubs: /* * Produce "v[i+:j] = value" where v is the image of the variable * containing the substring, i is starting position of the substring * j is the length, and value is the string v[i+:j]. If the length * (j) is one, just produce "v[i] = value". */ bp = BlkLoc(*dp); dp = VarLoc(bp->tvsubs.ssvar); if (!Tvar(bp->tvsubs.ssvar)) dp = (dptr)((word *)dp + Offset(bp->tvsubs.ssvar)); if (dp == (dptr)&tvky_sub) fprintf(f, "&subject"); else outimage(f, dp, restrict); if (bp->tvsubs.sslen == 1) fprintf(f, "[%ld]", (long)bp->tvsubs.sspos); else fprintf(f, "[%ld+:%ld]", (long)bp->tvsubs.sspos, (long)bp->tvsubs.sslen); if (dp == (dptr)&tvky_sub) { vp = BlkLoc(bp->tvsubs.ssvar); if (bp->tvsubs.sspos + bp->tvsubs.sslen - 1 > StrLen(vp->tvkywd.kyval)) return; StrLen(q) = bp->tvsubs.sslen; StrLoc(q) = StrLoc(vp->tvkywd.kyval) + bp->tvsubs.sspos - 1; fprintf(f, " = "); dp = &q; goto outimg; } else if (Qual(*dp)) { if (bp->tvsubs.sspos + bp->tvsubs.sslen - 1 > StrLen(*dp)) return; StrLen(q) = bp->tvsubs.sslen; StrLoc(q) = StrLoc(*dp) + bp->tvsubs.sspos - 1; fprintf(f, " = "); dp = &q; goto outimg; } return; case T_Tvtbl: bp = BlkLoc(*dp); /* * It is possible that the descriptor that thinks it is pointing * to a tabel-element trapped variable may actually be pointing * at a table element block which had been converted from a * trapped variable. Check for this first and if it is a table * element block, produce the outimage of its value. */ if (bp->tvtbl.title == T_Telem) { outimage(f, &bp->tvtbl.tval, restrict); return; } /* * It really was a tvtbl - produce "t[s]" where t is the image of * the table containing the element and s is the image of the * subscript. */ else { dp->dword = D_Table; BlkLoc(*dp) = bp->tvtbl.clink; outimage(f, dp, restrict); putc('[', f); outimage(f, &bp->tvtbl.tref, restrict); putc(']', f); return; } case T_Tvkywd: bp = BlkLoc(*dp); i = StrLen(bp->tvkywd.kyname); s = StrLoc(bp->tvkywd.kyname); while (i-- > 0) putc(*s++, f); fprintf(f, " = "); outimage(f, &bp->tvkywd.kyval, restrict); return; case T_Coexpr: fprintf(f, "co-expression_%ld(%ld)", (long)((struct b_coexpr *)BlkLoc(*dp))->id, (long)((struct b_coexpr *)BlkLoc(*dp))->size); return; case T_External: fprintf(f, "external(%d)",((struct b_external *)BlkLoc(*dp))->blksize); return; default: if (Type(*dp) <= MaxType) fprintf(f, "%s", blkname[Type(*dp)]); else syserr("outimage: unknown type"); } }/* * printimage - print character c on file f using escape conventions * if c is unprintable, '\', or equal to q. */static novalue printimage(f, c, q)FILE *f;int c, q; { if (printable(c)) { /* * c is printable, but special case ", ', and \. */ switch (c) { case '"': if (c != q) goto def; fprintf(f, "\\\""); return; case '\'': if (c != q) goto def; fprintf(f, "\\'"); return; case '\\': fprintf(f, "\\\\"); return; default: def: putc(c, f); return; } } /* * c is some sort of unprintable character. If it one of the common * ones, produce a special representation for it, otherwise, produce * its hex value. */ switch (c) { case '\b': /* backspace */ fprintf(f, "\\b"); return;#if !EBCDIC case '\177': /* delete */#else /* !EBCDIC */ case '\x07':#endif /* !EBCDIC */ fprintf(f, "\\d"); return;#if !EBCDIC case '\33': /* escape */#else /* !EBCDIC */ case '\x27':#endif /* !EBCDIC */ fprintf(f, "\\e"); return; case '\f': /* form feed */ fprintf(f, "\\f"); return; case LineFeed: /* new line */ fprintf(f, "\\n"); return;#if EBCDIC == 1 case '\x25': /* EBCDIC line feed */ fprintf(f, "\\l"); return;#endif /* EBCDIC == 1 */ case CarriageReturn: /* carriage return */ fprintf(f, "\\r"); return; case '\t': /* horizontal tab */ fprintf(f, "\\t"); return; case '\13': /* vertical tab */ fprintf(f, "\\v"); return; default: /* hex escape sequence */ fprintf(f, "\\x%02x", ToAscii(c & 0xff)); return; } } /* * listimage - print an image of a list. */static novalue listimage(f, lp, restrict)FILE *f;struct b_list *lp;int restrict; { register word i, j; register struct b_lelem *bp; word size, count; bp = (struct b_lelem *) lp->listhead; size = lp->size; if (restrict > 0 && size > 0) { /* * Just give indication of size if the list isn't empty. */ fprintf(f, "list_%ld(%ld)", (long)lp->id, (long)size); return; } /* * Print [e1,...,en] on f. If more than ListLimit elements are in the * list, produce the first ListLimit/2 elements, an ellipsis, and the * last ListLimit elements. */ fprintf(f, "list_%ld = [", (long)lp->id); count = 1; i = 0; if (size > 0) { for (;;) { if (++i > bp->nused) { i = 1; bp = (struct b_lelem *) bp->listnext; } if (count <= ListLimit/2 || count > size - ListLimit/2) { j = bp->first + i - 1; if (j >= bp->nslots) j -= bp->nslots; outimage(f, &bp->lslots[j], restrict+1); if (count >= size) break; putc(',', f); } else if (count == ListLimit/2 + 1) fprintf(f, "...,"); count++; } } putc(']', f); } #ifdef IconQsort/* qsort(base,nel,width,compar) - quicksort routine * * A Unix-compatible public domain quicksort. * Based on Bentley, CACM 28,7 (July, 1985), p. 675. */ novalue qsort(base, nel, w, compar)char *base;int nel, w;int (*compar)();{ int i, lastlow; if (nel < 2) return; qswap(base, base + w * (rand() % nel), w); lastlow = 0; for (i = 1; i < nel; i++) if ((*compar) (base + w *) < 0) qswap(base + w * i, base + w * (++lastlow), w); qswap(base, base + w * lastlow, w); qsort(base, lastlow, w, compar); qsort(base + w * (lastlow+1), nel-lastlow-1, w, compar);} static novalue qswap(a, b, w) /* swap *a and *b of width w for qsort*/char *a, *b;int w;{ register t; while (w--) { t = *a; *a++ = *b; *b++ = t; }}#endif /* IconQsort */ /* * qtos - convert a qualified string named by *dp to a C-style string. * Put the C-style string in sbuf if it will fit, otherwise put it * in the string region. */int qtos(dp, sbuf)dptr dp;char *sbuf; { register word slen; register char *c; c = StrLoc(*dp); slen = StrLen(*dp)++; if (slen >= MaxCvtLen) { if (strreq(slen + 1) == Error) return Error; if (c + slen != strfree) StrLoc(*dp) = alcstr(c, slen); alcstr("",(word)1); } else { StrLoc(*dp) = sbuf; for ( ; slen > 0; slen--) *sbuf++ = *c++; *sbuf = '\0'; } return Success; } /* * ctrace - procedure named s is being called with nargs arguments, the first * of which is at arg; produce a trace message. */novalue ctrace(dp, nargs, arg)dptr dp;int nargs;dptr arg; { showline(findfile(ipc.opnd), findline(ipc.opnd)); showlevel(k_level); putstr(stderr, dp); putc('(', stderr); while (nargs--) { outimage(stderr, arg++, 0); if (nargs) putc(',', stderr); } putc(')', stderr); putc('\n', stderr); fflush(stderr); } /* * rtrace - procedure named s is returning *rval; produce a trace message. */novalue rtrace(dp, rval)dptr dp;dptr rval; { inst t_ipc; /* * Compute the ipc of the return instruction. */ t_ipc.op = ipc.op - 1; showline(findfile(t_ipc.opnd), findline(t_ipc.opnd)); showlevel(k_level); putstr(stderr, dp); fprintf(stderr, " returned "); outimage(stderr, rval, 0); putc('\n', stderr); fflush(stderr); } /* * failtrace - procedure named s is failing; produce a trace message. */novalue failtrace(dp)dptr dp; { inst t_ipc; /* * Compute the ipc of the fail instruction. */ t_ipc.op = ipc.op - 1; showline(findfile(t_ipc.opnd), findline(t_ipc.opnd)); showlevel(k_level); putstr(stderr, dp); fprintf(stderr, " failed"); putc('\n', stderr); fflush(stderr); } /* * strace - procedure named s is suspending *rval; produce a trace message. */novalue strace(dp, rval)dptr dp;dptr rval; { inst t_ipc; /* * Compute the ipc of the suspend instruction. */ t_ipc.op = ipc.op - 1; showline(findfile(t_ipc.opnd), findline(t_ipc.opnd)); showlevel(k_level); putstr(stderr, dp); fprintf(stderr, " suspended "); outimage(stderr, rval, 0); putc('\n', stderr); fflush(stderr); } /* * atrace - procedure named s is being resumed; produce a trace message. */novalue atrace(dp)dptr dp; { inst t_ipc; /* * Compute the ipc of the instruction causing resumption. */ t_ipc.op = ipc.op - 1; showline(findfile(t_ipc.opnd), findline(t_ipc.opnd)); showlevel(k_level); putstr(stderr, dp); fprintf(stderr, " resumed"); putc('\n', stderr); fflush(stderr); } #ifdef Coexpr/* * coacttrace -- co-expression is being activated; produce a trace message. */novalue coacttrace(ccp, ncp)struct b_coexpr *ccp;struct b_coexpr *ncp; { struct b_proc *bp; inst t_ipc; bp = (struct b_proc *)BlkLoc(*argp); /* * Compute the ipc of the activation instruction. */ t_ipc.op = ipc.op - 1; showline(findfile(t_ipc.opnd), findline(t_ipc.opnd)); showlevel(k_level); putstr(stderr, &(bp->pname)); fprintf(stderr,"; co-expression_%ld : ", (long)ccp->id); outimage(stderr, (dptr)(sp - 3), 0); fprintf(stderr," @ co-expression_%ld\n", (long)ncp->id); fflush(stderr); } /* * corettrace -- return from co-expression; produce a trace message. */novalue corettrace(ccp, ncp)struct b_coexpr *ccp;struct b_coexpr *ncp; { struct b_proc *bp; inst t_ipc; bp = (struct b_proc *)BlkLoc(*argp); /* * Compute the ipc of the coret instruction. */ t_ipc.op = ipc.op - 1; showline(findfile(t_ipc.opnd), findline(t_ipc.opnd)); showlevel(k_level); putstr(stderr, &(bp->pname)); fprintf(stderr,"; co-expression_%ld returned ", (long)ccp->id); outimage(stderr, (dptr)(&ncp->es_sp[-3]), 0); fprintf(stderr," to co-expression_%ld\n", (long)ncp->id); fflush(stderr); } /* * cofailtrace -- failure return from co-expression; produce a trace message. */novalue cofailtrace(ccp, ncp)struct b_coexpr *ccp;struct b_coexpr *ncp; { struct b_proc *bp; inst t_ipc; bp = (struct b_proc *)BlkLoc(*argp); /* * Compute the ipc of the cofail instruction. */ t_ipc.op = ipc.op - 1; showline(findfile(t_ipc.opnd), findline(t_ipc.opnd)); showlevel(k_level); putstr(stderr, &(bp->pname)); fprintf(stderr,"; co-epression_%ld failed to co-expression_%ld\n", (long)ccp->id, (long)ncp->id); fflush(stderr); }#endif /* Coexpr */ /* * showline - print file and line number information. */static novalue showline(f, l)char *f;int l; { int i; i = strlen(f); while (i > 13) { f++; i--; } if (l > 0) fprintf(stderr, "%-13s: %4d ",f, l); else fprintf(stderr, " : "); } /* * showlevel - print "| " n times. */static novalue showlevel(n)register int n; { while (n-- > 0) { putc('|', stderr); putc(' ', stderr); } } /* * putpos - assign value to &pos */int putpos(dp,bp)dptr dp;struct b_tvkywd *bp; {#if MACINTOSH && MPW/* #pragma unused(bp) */#endif /* MACINTOSH && MPW */ register word l1; switch (cvint(dp)) { case T_Integer: l1 = cvpos(IntVal(*dp), StrLen(k_subject)); if (l1 == CvtFail) return Failure; k_pos = l1; return Success; default: RetError(101, *dp); } } /* * putsub - assign value to &subject */int putsub(dp,bp)dptr dp;struct b_tvkywd *bp; {#if MACINTOSH && MPW/* #pragma unused(bp) */#endif /* MACINTOSH && MPW */ char sbuf[MaxCvtLen]; switch (cvstr(dp, sbuf)) { case Cvt: if (strreq(StrLen(*dp)) == Error) return Error; StrLoc(*dp) = alcstr(StrLoc(*dp), StrLen(*dp)); /* no break */ case NoCvt: k_subject = *dp; k_pos = 1; return Success;
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:rmisc.
+++++ Continued from previous card +++++
default: RetError(103, *dp); } } /* * putint - assign integer value to keyword */int putint(dp,bp)dptr dp;struct b_tvkywd *bp; { switch (cvint(dp)) { case T_Integer: IntVal(bp->kyval) = IntVal(*dp); return Success; default: RetError(101, *dp); } } #ifdef Coexpr/* * pushact - push actvtr on the activator stack of ce */int pushact(ce, actvtr)struct b_coexpr *ce, *actvtr;{ struct astkblk *abp = ce->es_actstk, *nabp; struct actrec *arp; /* * If the last activator is the same as this one, just increment * its count. */ if (abp->nactivators > 0) { arp = &abp->arec[abp->nactivators - 1]; if (arp->activator == actvtr) { arp->acount++; return Success; } } /* * This activator is different from the last one. Push this activator * on the stack, possibly adding another block. */ if (abp->nactivators + 1 > ActStkBlkEnts) { nabp = alcactiv(); if (nabp == NULL) return Error; nabp->astk_nxt = abp; abp = nabp; } abp->nactivators++; arp = &abp->arec[abp->nactivators - 1]; arp->acount = 1; arp->activator = actvtr; ce->es_actstk = abp; return Success;} /* * popact - pop the most recent activator from the activator stack of ce * and return it. */struct b_coexpr *popact(ce)struct b_coexpr *ce;{ struct astkblk *abp = ce->es_actstk, *oabp; struct actrec *arp; struct b_coexpr *actvtr; /* * If the current stack block is empty, pop it. */ if (abp->nactivators == 0) { oabp = abp; abp = abp->astk_nxt; free((pointer)oabp); } if (abp == NULL || abp->nactivators == 0) syserr("empty activator stack\n"); /* * Find the activation record for the most recent co-expression. * Decrement the activation count and if it is zero, pop that * activation record and decrement the count of activators. */ arp = &abp->arec[abp->nactivators - 1]; actvtr = arp->activator; if (--arp->acount == 0) abp->nactivators--; ce->es_actstk = abp; return actvtr;} /* * topact - return the most recent activator of ce. */struct b_coexpr *topact(ce)struct b_coexpr *ce;{ struct astkblk *abp = ce->es_actstk; if (abp->nactivators == 0) abp = abp->astk_nxt; return abp->arec[abp->nactivators-1].activator;} #ifdef DeBugIconx/* * dumpact - dump an activator stack */novalue dumpact(ce)struct b_coexpr *ce;{ struct astkblk *abp = ce->es_actstk; struct actrec *arp; int i; if (abp) fprintf(stderr, "Ce %ld ", (long)ce->id); while (abp) { fprintf(stderr, "--- Activation stack block (%x) --- nact = %d\n", abp, abp->nactivators); for (i = abp->nactivators; i >= 1; i--) { arp = &abp->arec[i-1]; /*for (j = 1; j <= arp->acount; j++)*/ fprintf(stderr, "co-expression_%ld(%d)\n", (long)(arp->activator->id), arp->acount); } abp = abp->astk_nxt; }}#endif /* DeBugIconx */#endif /* Coexpr */ /* * findline - find the source line number associated with the ipc */int findline(ipc)word *ipc;{ uword ipc_offset; uword size; struct ipc_line *base; extern struct ipc_line *ilines, *elines; extern word *records; static two = 2; /* some compilers generate bad code for division by a constant that is a power of two ... */ if (!InRange(code,ipc,records)) return 0; ipc_offset = DiffPtrs((char *)ipc,(char *)code); base = ilines; size = DiffPtrs((char *)elines,(char *)ilines) / sizeof(struct ipc_line *); while (size > 1) { if (ipc_offset >= base[size / two].ipc) { base = &base[size / two]; size -= size / two; } else size = size / two; } return (int)base->line;}/* * findipc - find the first ipc associated with a source-code line number. */int findipc(line)int line;{ uword size; struct ipc_line *base; extern struct ipc_line *ilines, *elines; static two = 2; /* some compilers generate bad code for division by a constant that is a power of two ... */ base = ilines; size = DiffPtrs((char *)elines,(char *)ilines) / sizeof(struct ipc_line *); while (size > 1) { if (line >= base[size / two].line) { base = &base[size / two]; size -= size / two; } else size = size / two; } return base->ipc;} /* * findfile - find source file name associated with the ipc */char *findfile(ipc)word *ipc;{ uword ipc_offset; struct ipc_fname *p; extern struct ipc_fname *filenms, *efilenms; extern word *records; extern char *strcons; if (!InRange(code,ipc,records)) return "?"; ipc_offset = DiffPtrs((char *)ipc,(char *)code); for (p = efilenms - 1; p >= filenms; p--) if (ipc_offset >= p->ipc) return strcons + p->fname; fprintf(stderr,"bad ipc/file name table"); fflush(stderr); c_exit(ErrorExit);} #if IntBits == 16/* Shell sort with some enhancements from Knuth.. */novalue llqsort(base, nel, width, cmp )char *base;int nel;int width;int (*cmp)();{ register long i, j; long int gap; int k; char *p1, *p2, tmp; for( gap=1; gap <= nel; gap = 3*gap + 1 ) ; for( gap /= 3; gap > 0 ; gap /= 3 ) for( i = gap; i < nel; i++ ) for( j = i-gap; j >= 0 ; j -= gap ) { p1 = base + ( j * width); p2 = base + ((j+gap) * width); if( (*cmp)( p1, p2 ) <= 0 ) break; for( k = width; --k >= 0 ;) { tmp = *p1; *p1++ = *p2; *p2++ = tmp; } }} #endif /* IntBits == 16 *//* * doimage(c,q) - allocate character c in string space, with escape * conventions if c is unprintable, '\', or equal to q. * Returns number of characters allocated. */doimage(c, q)int c, q; { static char cbuf[5]; if (printable(c)) { /* * c is printable, but special case ", ', and \. */ switch (c) { case '"': if (c != q) goto def; alcstr("\\\"", (word)(2)); return 2; case '\'': if (c != q) goto def; alcstr("\\'", (word)(2)); return 2; case '\\': alcstr("\\\\", (word)(2)); return 2; default: def: cbuf[0] = c; alcstr(cbuf, (word)(1)); return 1; } } /* * c is some sort of unprintable character. If it is one of the common * ones, produce a special representation for it, otherwise, produce * its hex value. */ switch (c) { case '\b': /* backspace */ alcstr("\\b", (word)(2)); return 2;#if !EBCDIC case '\177': /* delete */#else /* !EBCDIC */ case '\x07': /* delete */#endif /* !EBCDIC */ alcstr("\\d", (word)(2)); return 2;#if !EBCDIC case '\33': /* escape */#else /* !EBCDIC */ case '\x27': /* escape */#endif /* !EBCDIC */ alcstr("\\e", (word)(2)); return 2; case '\f': /* form feed */ alcstr("\\f", (word)(2)); return 2; case LineFeed: /* new line */ alcstr("\\n", (word)(2)); return 2; case CarriageReturn: /* return */ alcstr("\\r", (word)(2)); return 2; case '\t': /* horizontal tab */ alcstr("\\t", (word)(2)); return 2; case '\13': /* vertical tab */ alcstr("\\v", (word)(2)); return 2; default: /* hex escape sequence */ sprintf(cbuf, "\\x%02x", c & 0xff); alcstr(cbuf, (word)(4)); return 4; } } /* * prescan(d) - return upper bound on length of expanded string. Note * that the only time that prescan is wrong is when the string contains * one of the "special" unprintable characters, e.g. tab. */word prescan(d)dptr d; { register word slen, len; register char *s, c; s = StrLoc(*d); len = 0; for (slen = StrLen(*d); slen > 0; slen--)#if EBCDIC#if SASC if (!isascii(c = (*s++)) || iscntrl(c))#else /* SASC */ if (!isprint(c = (*s++)))#endif /* SASC */#else /* EBCDIC */ if ((c = (*s++)) < ' ' || c >= 0177)#endif /* EBCDIC */ len += 4; else if (c == '"' || c == '\\' || c == '\'') len += 2; else len++; return len; } /* * getimage(dp1,dp2) - return string image of object dp1 in dp2. */int getimage(dp1,dp2) dptr dp1, dp2; { register word len, outlen, rnlen; register char *s; register union block *bp; char *type; char sbuf[MaxCvtLen]; FILE *fd; if (Qual(*dp1)) { /* * Get some string space. The magic 2 is for the double quote at each * end of the resulting string. */ if (strreq(prescan(dp1) + 2) == Error) return Error; len = StrLen(*dp1); s = StrLoc(*dp1); outlen = 2; /* * Form the image by putting a quote in the string space, calling * doimage with each character in the string, and then putting * a quote at then end. Note that doimage directly writes into the * string space. (Hence the indentation.) This techinique is used * several times in this routine. */ StrLoc(*dp2) = alcstr("\"", (word)(1)); while (len-- > 0) outlen += doimage(*s++, '"'); alcstr("\"", (word)(1)); StrLen(*dp2) = outlen; return Success; } switch (Type(*dp1)) { case T_Null: StrLoc(*dp2) = "&null"; StrLen(*dp2) = 5; return Success;#ifdef LargeInts case T_Bignum: { word slen; word dlen; slen = (BlkLoc(*dp1)->bignumblk.lsd - BlkLoc(*dp1)->bignumblk.msd + 1); dlen = slen * NB * 0.3010299956639812; /* 1 / log2(10) */ if (dlen > MaxDigits) { sprintf(sbuf,"integer(~%ld)",dlen - 2); /* center estimage */ len = strlen(sbuf); if (strreq(len) == Error) return Error; StrLoc(*dp2) = alcstr(sbuf,strlen(sbuf)); StrLen(*dp2) = len; return Success; } }#endif /* LargeInts */ case T_Integer: case T_Real: /* * Form a string representing the number and allocate it. */ *dp2 = *dp1; /* don't clobber dp1 */ cvstr(dp2, sbuf); len = StrLen(*dp2); if (strreq(len) == Error) return Error; StrLoc(*dp2) = alcstr(StrLoc(*dp2), len); StrLen(*dp2) = len; return Success; case T_Cset: /* * Check for distinguished csets by looking at the address of * of the object to image. If one is found, make a string * naming it and return. */ if (BlkLoc(*dp1) == ((union block *)&k_ascii)) { StrLoc(*dp2) = "&ascii"; StrLen(*dp2) = 6; return Success; } else if (BlkLoc(*dp1) == ((union block *)&k_cset)) { StrLoc(*dp2) = "&cset"; StrLen(*dp2) = 5; return Success; } else if (BlkLoc(*dp1) == ((union block *)&k_digits)) { StrLoc(*dp2) = "&digits"; StrLen(*dp2) = 7; return Success; } else if (BlkLoc(*dp1) == ((union block *)&k_lcase)) { StrLoc(*dp2) = "&lcase"; StrLen(*dp2) = 6; return Success; } else if (BlkLoc(*dp1) == ((union block *)&k_letters)) { StrLoc(*dp2) = "&letters"; StrLen(*dp2) = 8; return Success; } else if (BlkLoc(*dp1) == ((union block *)&k_ucase)) { StrLoc(*dp2) = "&ucase"; StrLen(*dp2) = 6; return Success; } /* * Convert the cset to a string and proceed as is done for * string images but use a ' rather than " to bound the * result string. */ cvstr(dp1, sbuf); if (strreq(prescan(dp1) + 2) == Error) return Error; len = StrLen(*dp1); s = StrLoc(*dp1); outlen = 2; StrLoc(*dp2) = alcstr("'", (word)(1)); while (len-- > 0) outlen += doimage(*s++, '\''); alcstr("'", (word)(1)); StrLen(*dp2) = outlen; return Success; case T_File: /* * Check for distinguished files by looking at the address of * of the object to image. If one is found, make a string * naming it and return. */ if ((fd = BlkLoc(*dp1)->file.fd) == stdin) { StrLen(*dp2) = 6; StrLoc(*dp2) = "&input"; } else if (fd == stdout) { StrLen(*dp2) = 7; StrLoc(*dp2) = "&output"; } else if (fd == stderr) { StrLen(*dp2) = 7; StrLoc(*dp2) = "&errout"; } else { /* * The file is not a standard one; form a string of the form * file(nm) where nm is the argument originally given to * open. */ if (strreq(prescan(&BlkLoc(*dp1)->file.fname)+6) == Error) return Error; len = StrLen(BlkLoc(*dp1)->file.fname); s = StrLoc(BlkLoc(*dp1)->file.fname); outlen = 6; StrLoc(*dp2) = alcstr("file(", (word)(5)); while (len-- > 0) outlen += doimage(*s++, '\0'); alcstr(")", (word)(1)); StrLen(*dp2) = outlen; } return Success; case T_Proc: /* * Produce one of: * "procedure name" * "function name" * "record constructor name" * * Note that the number of dynamic locals is used to determine * what type of "procedure" is at hand. */ len = StrLen(BlkLoc(*dp1)->proc.pname); s = StrLoc(BlkLoc(*dp1)->proc.pname); switch ((int)BlkLoc(*dp1)->proc.ndynam) { default: type = "procedure "; break; case -1: type = "function "; break; case -2: type = "record constructor "; break; } outlen = strlen(type); if (strreq(len + outlen) == Error) return Error; StrLoc(*dp2) = alcstr(type, outlen); alcstr(s, len); StrLen(*dp2) = len + outlen; return Success; case T_List: /* * Produce: * "list_m(n)" * where n is the current size of the list. */ bp = BlkLoc(*dp1); sprintf(sbuf, "list_%ld(%ld)", (long)bp->list.id, (long)bp->list.size); len = strlen(sbuf); if (strreq(len) == Error) return Error; StrLoc(*dp2) = alcstr(sbuf, len); StrLen(*dp2) = len; return Success; case T_Table: /* * Produce: * "table_m(n)" * where n is the size of the table. */ bp = BlkLoc(*dp1); sprintf(sbuf, "table_%ld(%ld)", (long)bp->table.id, (long)bp->table.size); len = strlen(sbuf); if (strreq(len) == Error) return Error; StrLoc(*dp2) = alcstr(sbuf, len); StrLen(*dp2) = len; return Success; case T_Set: /* * Produce "set_m(n)" where n is size of the set. */ bp = BlkLoc(*dp1); sprintf(sbuf, "set_%ld(%ld)", (long)b
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:rmisc.
+++++ Continued from previous card +++++
p->set.id, (long)bp->set.size); len = strlen(sbuf); if (strreq(len) == Error) return Error; StrLoc(*dp2) = alcstr(sbuf,len); StrLen(*dp2) = len; return Success; case T_Record: /* * Produce: * "record name_m(n)" -- under construction * where n is the number of fields. */ bp = BlkLoc(*dp1); rnlen = StrLen(bp->record.recdesc->proc.recname); if (strreq(15 + rnlen) == Error) /* 15 = *"record " + *"(nnnnnn)"*/ return Error; bp = BlkLoc(*dp1); sprintf(sbuf, "_%ld(%ld)", (long)bp->record.id, (long)bp->record.recdesc->proc.nfields); len = strlen(sbuf); StrLoc(*dp2) = alcstr("record ", (word)(7)); alcstr(StrLoc(bp->record.recdesc->proc.recname),rnlen); alcstr(sbuf, len); StrLen(*dp2) = 7 + len + rnlen; return Success; case T_Coexpr: /* * Produce: * "co-expression_m(n)" * where m is the number of the co-expressions and n is the * number of results that have been produced. */ if (strreq((uword)30) == Error) return Error; sprintf(sbuf, "_%ld(%ld)", (long)BlkLoc(*dp1)->coexpr.id, (long)BlkLoc(*dp1)->coexpr.size); len = strlen(sbuf); StrLoc(*dp2) = alcstr("co-expression", (word)(13)); alcstr(sbuf, len); StrLen(*dp2) = 13 + len; return Success; case T_External: /* * For now, just produce "external(n)". */ sprintf(sbuf, "external(%ld)", (long)BlkLoc(*dp1)->externl.blksize); len = strlen(sbuf); if (strreq(len) == Error) return Error; StrLoc(*dp2) = alcstr(sbuf, len); StrLen(*dp2) = len; return Success; default: RetError(123,*dp1); } } /* * printable(c) -- is c a "printable" character? */int printable(c)int c; {/* * The following code is operating-system dependisc.01]. * Determine if a character is "printable". */#if PORT return isprint(c);Deliberate Syntax Error#endif /* PORT */#if MVS || VM#if SASC return isascii(c) && !iscntrl(c);#else /* SASC */ return isprint(c);#endif /* SASC */#endif /* MVS || VM */#if AMIGA || ATARI_ST || HIGHC_386 || MACINTOSH || MSDOS || OS2 || UNIX || VMS return (isascii(c) && isprint(c));#endif /* AMIGA || ATARI_ST ... *//* * End of operating-system specific code. */ } #ifndef AsmOver/* * add, sub, mul, neg with overflow check * all return 1 if ok, 0 if would overflow *//* * Note: on some systems an improvement in performance can be obtained by * replacing the C functions that follow by checks written in assembly * language. To do so, add #define AsmOver to ../h/define.h. If your * C compiler supports the asm directive, but the new code at the end * of this section under control of #else. Otherwise put it a separate * file. */extern int over_flow;word add(a, b)word a, b;{ if ((a ^ b) >= 0 && (a >= 0 ? b > MaxLong - a : b < MinLong - a)) { over_flow = 1; return 0; } else { over_flow = 0; return a + b; }}word sub(a, b)word a, b;{ if ((a ^ b) < 0 && (a >= 0 ? b < a - MaxLong : b > a - MinLong)) { over_flow = 1; return 0; } else { over_flow = 0; return a - b; }}word mul(a, b)word a, b;{ if (b != 0) { if ((a ^ b) >= 0) { if (a >= 0 ? a > MaxLong / b : a < MaxLong / b) { over_flow = 1; return 0; } } else if (b != -1 && (a >= 0 ? a > MinLong / b : a < MinLong / b)) { over_flow = 1; return 0; } } over_flow = 0; return a * b;}/* MinLong / -1 overflows; need div3 too */word neg(a)word a;{ if (a == MinLong) { over_flow = 1; return 0; } over_flow = 0; return -a;}#endif /* AsmOver */ :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:rproto.h
/* * File: rstruct.c * Contents: addmem, cplist, cpset, hmake, hchain, hgener, hgrow, hshrink, memb */#include "::h:config.h"#include "::h:rt.h"#include "rproto.h"/* * addmem - add a new set element block in the correct spot in * the bucket chain. */novalue addmem(ps,pe,pl)union block **pl;struct b_set *ps;struct b_selem *pe; { ps->size++; if (*pl != NULL ) pe->clink = *pl; *pl = (union block *) pe; } /* * cplist(dp1,dp2,i,j) - copy sublist dp1[i:j] into dp2. */int cplist(dp1, dp2, i, j)dptr dp1, dp2;word i, j; { register dptr dp; word size, nslots; struct b_list *lp1, *lp2; struct b_lelem *bp1, *bp2; /* * Calculate the size of the sublist and fail if it's less than 0. * Also round nslots up to the minimum list block size. */ size = nslots = j - i; /* * Get pointers to the list and list elements for the source list * (bp1, lp1) and the sublist (bp2, lp2). */ if (blkreq(sizeof(struct b_list) + sizeof(struct b_lelem) + nslots * sizeof(struct descrip)) == Error) return Error; lp1 = (struct b_list *) BlkLoc(*dp1); bp1 = (struct b_lelem *) lp1->listhead; lp2 = (struct b_list *) alclist(size); bp2 = (struct b_lelem *) alclstb(nslots, (word)0, size); lp2->listhead = lp2->listtail = (union block *) bp2; dp = bp2->lslots; /* * Locate the block containing element i in the source list. */ if (size > 0) { while (i > bp1->nused) { i -= bp1->nused; bp1 = (struct b_lelem *) bp1->listnext; } } /* * Copy elements from the source list into the sublist, moving to * the next list block in the source list when all elements in a * block have been copied. */ while (size > 0) { j = bp1->first + i - 1; if (j >= bp1->nslots) j -= bp1->nslots; *dp++ = bp1->lslots[j]; if (++i > bp1->nused) { i = 1; bp1 = (struct b_lelem *) bp1->listnext; } size--; } /* * Fix type and location fields for the new list. */ dp2->dword = D_List; BlkLoc(*dp2) = (union block *) lp2; return Success; } /* * cpset(dp1,dp2,n) - copy set dp1 to dp2, reserving memory for n entries. */int cpset(dp1, dp2, n)dptr dp1, dp2;word n; { register union block **tp, *ep, *old, *new; register struct b_slots *seg; register word i, slotnum; /* * Make a new set organized like dp1, with room for n elements. */ new = hmake(T_Set, BlkLoc(*dp1)->set.mask + 1, n); if (new == NULL) return Error; /* * Copy the header and slot blocks. */ old = BlkLoc(*dp1); new->set.size = old->set.size; /* actual set size */ new->set.mask = old->set.mask; /* hash mask */ for (i = 0; i < HSegs && old->set.hdir[i] != NULL; i++) memcopy((char *)new->set.hdir[i], (char *)old->set.hdir[i], old->set.hdir[i]->blksize); /* * Work down the chain of element blocks in each bucket * and create identical chains in new set. */ for (i = 0; i < HSegs && (seg = new->set.hdir[i]) != NULL; i++) for (slotnum = segsize[i] - 1; slotnum >= 0; slotnum--) { tp = &seg->hslots[slotnum]; for (ep = *tp; ep != NULL; ep = *tp) { *tp = (union block *)alcselem(&ep->selem.setmem, ep->selem.hashnum); (*tp)->selem.clink = ep->selem.clink; tp = &(*tp)->selem.clink; } } dp2->dword = D_Set; BlkLoc(*dp2) = new; if (TooSparse(new)) hshrink(dp2); return Success; } /* * hmake - make a hash structure (Set or Table) with a given number of slots. * hmake also ensures adequate storage for *nelem* elements, but does not * allocate then. If *nslots* is zero, a value appropriate for *nelem* * elements is chosen. */union block *hmake(tcode, nslots, nelem)int tcode;word nslots, nelem; { word seg, t, nbytes, blksize, elemsize; union block *blk; if (nslots == 0) nslots = (nelem + MaxHLoad - 1) / MaxHLoad; for (seg = t = 0; seg < (HSegs - 1) && (t += segsize[seg]) < nslots; seg++) ; nslots = ((word)HSlots) << seg; /* ensure legal power of 2 */ if (tcode == T_Table) { blksize = sizeof(struct b_table); elemsize = sizeof(struct b_telem); } else { /* T_Set */ blksize = sizeof(struct b elemsize = sizeof(struct b_selem); } nbytes = blksize + (seg + 1) * (sizeof(struct b_slots) - (HSlots*WordSize)) + nslots * WordSize + nelem * elemsize; if (blkreq(nbytes) == Error) return NULL; /* sorry, no memory */ blk = alchash(tcode); for (; seg >= 0; seg--) blk->set.hdir[seg] = alcsegment(segsize[seg]); blk->set.mask = nslots - 1; return blk; } /* * hchain - return a pointer to the word that points to the head of the hash * chain for hash number hn in hashed structure s. *//* * lookup table for log to base 2; must have powers of 2 through (HSegs-1)/2. */static unsigned char log2[] = { 0,1,2,2, 3,3,3,3, 4,4,4,4, 4,4,4,4, 5,5,5,5, 5,5,5,5, 5,5,5,5, 5,5,5,5, };union block **hchain(pb, hn)union block *pb;register uword hn; { register struct b_set *ps; register word slotnum, segnum, segslot; ps = (struct b_set *)pb; slotnum = hn & ps->mask; if (slotnum >= HSlots * sizeof(log2)) segnum = log2[slotnum >> (LogHSlots + HSegs/2)] + HSegs/2; else segnum = log2[slotnum >> LogHSlots]; segslot = hn & (segsize[segnum] - 1); return &ps->hdir[segnum]->hslots[segslot]; } /* * hgener - agent function to generate the elements of a hashed structure. * * Arg1 = set or table to enumerate * Arg2 = integer value indicating desired action: * 0 generate set elements * 1 generate table keys * 2 generate table values * * Carefully generate each element exactly once, even if the hash chains * split while suspended. Do this by recording the state of things at the * time of the split and checking past history when starting to process a * new chain. * * Elements inserted or deleted while the generator is suspended may or * may not be generated. * * We assume that no structure *shrinks* after its initial creation; they * only *grow*. */AgtDcl(hgener) { int i, segnum; word d, m, func, slotnum; uword hn; union block *ep; word tmask; /* structure mask before suspension */ word sgmask[HSegs]; /* mask being used when the segment was created */ uword sghash[HSegs]; /* hashnum in process when the segment was created */ for (i = 0; i < HSegs; i++) sghash[i] = sgmask[i] = 0; /* set initial state */ tmask = BlkLoc(Arg1)->table.mask; func = IntVal(Arg2); /* save function code */ Arg2.dword = D_Telem; /* use Arg2 to tend address */ for (segnum = 0; segnum < HSegs; segnum++) { if (BlkLoc(Arg1)->table.hdir[segnum] == NULL) break; for (slotnum = 0; slotnum < segsize[segnum]; slotnum++) { ep = BlkLoc(Arg1)->table.hdir[segnum]->hslots[slotnum]; /* * Check to see if parts of this hash chain were already processed. * This could happen if the elements were in a different chain, * but a split occurred while we were suspended. */ for (i = segnum; (m = sgmask[i]) != 0; i--) { d = (word)(m & slotnum) - (word)(m & sghash[i]); if (d < 0) /* if all elements processed earlier */ ep = NULL; /* skip this slot */ else if (d == 0) { /* * This chain was split from its parent while the parent was * being processed. Skip past elements already processed. */ while (ep != NULL && ep->telem.hashnum <= sghash[i]) ep = ep->telem.clink; } } /* * Process the elements of the hash chain, in turn. */ while (ep != NULL) { switch ((int)func) { case 0: Arg0 = ep->selem.setmem; break; case 1: Arg0 = ep->telem.tref; break; case 2: Arg0 = ep->telem.tval; break; } BlkLoc(Arg2) = ep; /* save pointer, so it gets tended */ Suspend; /* suspend, returning current element */ ep = BlkLoc(Arg2); /* restore pointer */ if (BlkLoc(Arg1)->table.mask != tmask && (ep->telem.clink == NULL || ep->telem.clink->telem.hashnum != ep->telem.hashnum)) { /* * The set or table's hash buckets split, once or more, while * we were suspended. (We notice this unless the next entry * has same hash value as the current one. In that case we * ignore it for now and will pick it up on the next pass.) * * Make a note of the current state. */ hn = ep->telem.hashnum; for (i = 1; i < HSegs; i++) if ((((word)HSlots) << (i - 1)) > tmask) { /* * For the newly created segments only, save the mask and * hash number being processed at time of creation. */ sgmask[i] = tmask; sghash[i] = hn; } tmask = BlkLoc(Arg1)->table.mask; /* * Find the next element in our original segment by starting * from the beginning and skipping through the current hash * number. We can't just follow the link from the current * element, because it may have moved to a new segment. */ ep = BlkLoc(Arg1)->table.hdir[segnum]->hslots[slotnum]; while (ep != NULL && ep->telem.hashnum <= hn) ep = ep->telem.clink; } else { /* * Nothing happened during the suspend, or else if it did we're * between items with identical hash numbers. Just move on. */ ep = ep->telem.clink; } } } } Fail; } /* * hgrow - split a hashed structure (doubling the buckets) for faster access. */novalue hgrow(dp)dptr dp; { register union block **tp0, **tp1, *ep; register word newslots, slotnum, segnum; struct b_set *ps; struct b_slots *seg, *newseg; union block **curslot; ps = (struct b_set *)BlkLoc(*dp); if (ps->hdir[HSegs-1] != NULL) return; /* can't split further */ newslots = ps->mask + 1; if (blkreq(sizeof(struct b_slots) + (newslots - HSlots) * WordSize) == Error) return; /* sorry, no memory */ ps = (struct b_set *)BlkLoc(*dp); /* refresh address -- may have moved */ newseg = alcsegment(newslots); curslot = newseg->hslots; for (segnum = 0; (seg = ps->hdir[segnum]) != NULL; segnum++) for (slotnum = 0; slotnum < segsize[segnum]; slotnum++) { tp0 = &seg->hslots[slotnum]; /* ptr to tail of old slot */ tp1 = curslot++; /* ptr to tail of new slot */ for (ep = *tp0; ep != NULL; ep = ep->selem.clink) { if ((ep->selem.hashnum & newslots) == 0) { *tp0 = ep; /* element does not move */ tp0 = &ep->selem.clink; } else { *tp1 = ep; /* element moves to new slot */ tp1 = &ep->selem.clink; } } *tp0 = *tp1 = NULL; } ps->hdir[segnum] = newseg; ps->mask = (ps->mask << 1) | 1; } /* * hshrink - combine buckets in a set or table that is too sparse. * * Call this only for newly created structures. Shrinking an active structure * can wreak havoc on suspended generators. */novalue hshrink(dp)dptr dp; { register union block **tp, *ep0, *ep1; int topseg, curseg; word slotnum; struct b_set *ps; struct b_slots *seg; union block **uppslot; ps = (struct b_set *)BlkLoc(*dp); topseg = 0; for (topseg = 1; topseg < HSegs && ps->hdir[topseg] != NULL; topseg++) ; topseg--; while (TooSparse(ps)) { uppslot = ps->hdir[topseg]->hslots; ps->hdir[topseg--] = NULL; for (curseg = 0; (seg = ps->hdir[curseg]) != NULL; curseg++) for (slotnum = 0; slotnum < segsize[curseg]; slotnum++) { tp = &seg->hslots[slotnum]; /* tail pointer */ ep0 = seg->hslots[slotnum]; /* lower slot entry pointer */ ep1 = *uppslot++; /* upper slot entry pointer */ while (ep0 != NULL && ep1 != NULL) if (ep0->selem.hashnum < ep1->selem.hashnum) { *tp = ep0; tp = &ep0->selem.clink; ep0 = ep0->selem.clink; } else { *tp = ep1; tp = &ep1->selem.clink; ep1 = ep1->selem.clink; } while (ep0 != NULL) { *tp = ep0; tp = &ep0->selem.clink; ep0 = ep0->selem.clink; } while (ep1 != NULL) { *tp = ep1; tp = &ep1->selem.clink; ep1 = ep1->selem.clink; } } ps->mask >>= 1; } } /* * memb - sets res flag to 1 if x is a member of a set or table, or to 0 if not. * Returns a pointer to the word which points to the element, or which * would point to it if it were there. */union block **memb(pb, x, hn, res)union block *pb;dptr x;register uword hn;int *res; /* pointer to integer result flag */ { struct b_set *ps; register union block **lp; register struct b_selem *pe; register uword eh; ps = (struct b_set *)pb; lp = hchain(pb, hn); /* * Look for x in the hash chain. */ *res = 0; while ((pe = (struct b_selem *)*lp) != NULL) { eh = pe->hashnum; if (eh > hn) /* too far - it isn't there */ return lp; else if ((eh == hn) && (equiv(&pe->setmem, x))) { *res = 1; return lp; } /* * We haven't reached the right hashnumber yet or * the element isn't the right one so keep looking. */ lp = &(pe->clink); } /* * At end of chain - not there. */ return lp; } :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:rswitch.a
** Co-expression context switch for Macintosh Icon* STRING C PRINT LITS CASE OBJ PRINT OFF INCLUDE 'SysEqu.a' PRINT ON IMPORT interp,syserr SEG 'rswitch'coswitch PROC EXPORTcs_regs REG D2-D7/A2-A7 ;These 12 registers get saved ; on co-expression switchcs_nregs EQU 12 ;Number of registers saved;; Save registers of the co-expression being deactivated.; MOVE.L 4(SP),A0 ;Get address of old task's registers MOVE.L 8(SP),A1 ;Get address of new task's registers ADD.L #cs_nregs*4,A0 ;Bump to end of area for backward move MOVEM.L cs_regs,-(A0) ;Save registers TST.L 12(SP) ;Check whether this is first activation BNE.S not_first ;Jump if not first;; Come here for co-expression's first activation. Set the stack; pointer to its stack and call interp.first MOVE.L #0,StkLowPt ;Disable Mac's "stack sniffer" MOVE.L (A1),SP ;Get new stack pointer MOVE.L #0,-(SP) ;Set up args for interp MOVE.L #0,-(SP) ; ... JSR interp ;Call interp ADD.L #8,SP ;Pop args off stack;; We should never get here, but just in case ...; PEA #'interp() returned in coswitch' JSR syserr ;System error;; Come here if not the first activation. Restore registers and return.;not_first MOVEM.L (A1)+,cs_regs ;Restore registers RTS ;Return;; This routine is called at the end of an Icon run. It re-enables; the "stack sniffer".;ResetStack PROC EXPORT MOVE.L SP,StkLowPt RTS END :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:iconx Folder:rsys.c
/* * File: rsys.c * Contents: getstrg, host, longread, putstr */#include "::h:config.h"#include "::h:rt.h"#include "rproto.h"#if AMIGA#if LATTICE#include <ios1.h>#endif /* LATTICE */#endif /* AMIGA *//* * getstrg - read a line into buf from file fd. At most maxi characters * are read. getstrg returns the length of the line, not counting * the newline. Returns -1 if EOF and -2 if length was limited by * maxi. [[ Needs ferror() check. ]] */int getstrg(buf, maxi, fd)register char *buf;int maxi;FILE *fd; { register int c, l;#if AMIGA#if LATTICE /* This code is special for Lattice 4.0. It was different for * Lattice 3.10 and probably won't work for other C compilers. */ extern struct UFB _ufbs[]; if (IsInteractive(_ufbs[fileno(fd)].ufbfh)) return read(fileno(fd),buf,maxi);#endif /* LATTICE */#endif /* AMIGA */ l = 0; while ((c = fgetc(fd)) != '\n') { if (c == EOF) if (l > 0) return l; else return -1; if (++l > maxi) { ungetc(c, fd); return -2; } *buf++ = c; } return l; } #ifdef UtsName#include <sys/utsname.h>#endif /* UtsName *//* * iconhost - return some sort of host name into the buffer pointed at * by hostname. This code accommodates several different host name * fetching schemes. */novalue iconhost(hostname)char *hostname; {#ifdef WhoHost /* * The host name is in /usr/include/whoami.h. (V7, 4.[01]bsd) */ whohost(hostname);#endif /* WhoHost */#ifdef UtsName { /* * Use the uname system call. (System III & V) */ struct utsname utsn; uname(&utsn); strcpy(hostname,utsn.nodename); }#endif /* UtsName */#ifdef GetHost /* * Use the gethostname system call. (4.2bsd) */ gethostname(hostname,MaxCvtLen);#endif /* GetHost */#if VMS /* * VMS has its own special logic. */ char *h; if (!(h = getenv("ICON$HOST")) && !(h = getenv("SYS$NODE"))) h = "VAX/VMS"; strcpy(hostname,h);#endif /* VMS */#ifdef HostStr /* * The string constant HostStr contains the host name. */ strcpy(hostname,HostStr);#endif /* HostStr */ } #ifdef WhoHost#define HdrFile "/usr/include/whoami.h"/* * whohost - look for a line of the form * #define sysname "name" * in HdrFile and return the name. */novalue whohost(hostname)char *hostname; { char buf[BUFSIZ]; FILE *fd; fd = fopen(HdrFile, "r"); if (fd == NULL) { sprintf(buf, "Cannot open %s, no value for &host\n", HdrFile); syserr(buf); } for (;;) { /* each line in the file */ if (fgets(buf, sizeof buf, fd) == NULL) { sprintf(buf, "No #define for sysname in %s, no value for &host\n", HdrFile); syserr(buf); } if (sscanf(buf,"#define sysname \"%[^\"]\"", hostname) == 1) { fclose(fd); return; } } }#endif /* WhoHost */ /* * Read a long string in shorter parts. (Standard read may not handle long * strings.) */word longread(s,width,len,fname)FILE *fname;int width;char *s;long len;{ long tally = 0; long n = 0; while (len > 0) { n = fread(s, width, (int)((len < MaxIn) ? len : MaxIn), fname); if (n <= 0) return tally; tally += n; s += n; len -= n; } return tally; * Print string referenced by descriptor d. Note, d must not move during * a garbage collection. */int putstr(f, d)register FILE *f;dptr d; { register char *s; register word l; l = StrLen(*d); if (l == 0) return Success; s = StrLoc(*d);#ifdef FixedRegions if (longwrite(s,l,f) < 0) return Failure; else return Success;#else /* FixedRegions */ /* * In expandable regions storage management, the first output to a file may * cause allocation, which in turn may cause a garbage collection, changing * where the string is. So write one character and reload the address * of the string from the tended descriptor. */ putc(*s, f); s = StrLoc(*d) + 1; if (longwrite(s,--l,f) < 0) return Failure; else return Success;#endif /* FixedRegions */ } :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:memmon Folder:doc.clr
# A monochrome color scheme for use in printed documentation.## The idea here is to give a general impression, not necessarily# to distingish all the different types.free 111coexpr 222alien 666string 777subs 777file 666refresh 222int 777real 777record 333set 333selem 555list 222lelem 444table 222telem 666tvtbl 444hash 333cset 555ext 666background 000bsep 000ssep 333marked 000unmarked 000status 777prompt 777title 777regions 777black 000grey 222white 777blink 777 :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:memmon Folder:lw.clr
# A color scheme optimized for a monochrome LaserWriter.## If you know enough about Icon block sizes, this palette gives# enough information to distinguish the various block types.free 111coexpr 333alien 555string 777subs 776file 100refresh 100int 777real 777record 777set 122selem 122list 444lelem 444table 776telem 776tvtbl 776hash 222cset 111ext 555background 000bsep 000ssep 333marked 000unmarked 000status 777prompt 777title 777regions 777black 000grey 222white 777blink 777 :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:memmon Folder:mbatch.c
/* * mbatch.c: basic interface for batch-mode output. */#include "memmon.h"static int nframes = 0; /* number of images written *//* * Text buffer. */static char tbuf[TextLines][TextLength + 1]; /* text chars */static unsigned char tfg[TextLines][TextLength + 1]; /* foreground color */static unsigned char tbg[TextLines][TextLength + 1]; /* background color *//* * Memory map buffer. */static unsigned char *mbuf; /* pixel color buffer */static word mbufsiz = 0; /* current allocated size *//* * devmap() - load color map into device. */novalue devmap() { /* nothing to do */ }/* * devflood(c) - fill image with color c. */novalue devflood(c)int c; { word n; n = (word)memheight * (word)width; /* max display w/o new refresh */ if (n > mbufsiz) { if (mbuf) free((char *)mbuf); n = (word)memheight * (word)width; mbuf = (unsigned char *)malloc((msize)n); if (!mbuf) { fprintf(stderr, "%s: out of memory", progname); exit(ErrorExit); } mbufsiz = n; } memfill((char *)mbuf, c, (word)mbufsiz); memfill((char *)tbuf, 0, (word)(TextLines * TextLength)); memfill((char *)tbg, c, (word)(TextLines * TextLength)); }/* * devpaint(start, n, color, b) - paint n pixels in given color. * If b >= 0, the last pixel is to be that color instead (for a border) */novalue devpaint(s, n, c, b)word s, n;int c, b; { unsigned char *p; if (b >= 0) /* if border, decr total count */ n--; p = mbuf + s; while (n--) /* fill pixels */ *p++ = c; if (b >= 0) /* if border, set its value */ *p++ = b; }/* * devtext(string, row, col, fgcolr, bgcolr) - write text data. */novalue devtext(s, row, col, fg, bg)char *s;int row, col, fg, bg; { int n; n = strlen(s) + 1; while (n--) { /* copy including terminator */ tbuf[row][col] = *s++; tfg[row][col] = fg; tbg[row][col] = bg; if (col++ > TextLength) break; /* but no wraparound */ } }/* * devsnap() - take a snapshot of the current display. */novalue devsnap() { int c, row, col, k; batbegin(); /* begin batch frame */ /* * identify text strings and pass individually */ if (textrow > 0) { for (row = 0; row < TextLines; row++) { /* for each text line */ col = 0; while (col < TextLength) { if (tbuf[row][col] == '\0' || tfg[row][col] == tbg[row][col]) col++; /* skip unused text positions */ else { for (k = col; k < TextLength && tfg[row][k]==tfg[row][col] && tbuf[row][k]; k++) ; /* find run of one color */ c = tbuf[row][k]; tbuf[row][k] = '\0'; /* temporarily terminate string */ battext(tbuf[row] + col, row, col, (int)tfg[row][col], (int)tbg[row][col]); tbuf[row][k] = c; /* restore text buffer */ col = k; } } } } /* * dump memory to finish up */ batmem(mbuf); /* write memory dump, finish frame */ nframes++; }/* * devflush() - flush output. (No action needed.) */novalue devflush() { }/* * devterm() - terminate graphics. */novalue devterm() { fprintf(stderr, "%d %s written\n", nframes, (nframes==1)?"frame":"frames"); batterm(); } :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:memmon Folder:mcolors.c
/* * mcolors.c: device-independent color routines. */#include "memmon.h"hidden novalue setcolor Params((char *label, char *value));hidden novalue uniqcolors Params((noargs));/* * Color labels and codes. */static struct centry { char *label; /* label, for legend or recoloring */ char code; /* block code */ };#define Color(sym, code, lab) { lab, code },static struct centry cdata[NColors] = {#include "msymbols.h" };/* * Default color values. */struct blkcolor { char *label; /* label */ char value[4]; /* value, as a 3-char string */ };#define ColorDefault(label, spec) { label, spec },static struct blkcolor defcolors [] = {#include "mcolors.h" { 0, "" } /* terminator */ };/* * initcolors() - initialize color system. */novalue initcolors() { char *fname; int i; struct blkcolor *v; /* initialize char-to-color mapping */ for (i = 0; i < NColors; i++) if (cdata[i].code != 0) blkcolor[cdata[i].code] = i; /* set color for character */ /* set color defaults */ for (v = defcolors; v->label; v++) setcolor(v->label, v->value); uniqcolors(); /* if the environment variable MMCOLORS is set, read it for colors */ if ((fname = getenv("MMCOLORS")) != NULL) readcolors(fname); }/* * readcolors(filename) - read a color specification file. */#define ColrArgs 2 /* number of args on a color spec line */novalue readcolors(filename)char *filename; { FILE *f; int n; char line[LineSize]; char *p; char *w[ColrArgs]; if (strcmp(filename, "-") == 0) f = stdin; else f = fopen(filename, "r"); if (!f) pexit(filename); while (fgets(line, LineSize, f)) { p = trim(line, '#'); n = chop(p, w, ColrArgs, 0); if (n > 0) setcolor(w[0], w[1]); } uniqcolors(); if (strcmp(filename, "-") == 0) clearerr(f); else fclose(f); }/* * setcolor(label, value) - set a color in the color map. */static novalue setcolor(label, value)char *label;char *value; { int i, r, g, b; static int map8[] = { 0, 36, 73, 109, 146, 182, 219, 255 }; for (i = 0; i < NColors; i++) if (strcmp(label, cdata[i].label) == 0) break; if (i >= NColors) { fprintf(stderr, "%s: unrecognized color label: %s\n", progname, label); return; } if (strlen(value) != 3 || sscanf(value, "%1o%1o%1o", &r, &g, &b) != 3) { fprintf(stderr, "%s: bad color value: %s %s\n", progname, label, value); return; } cmap[i].red = map8[r]; cmap[i].green = map8[g]; cmap[i].blue = map8[b]; }/* * uniqcolors() - set uniq pointers in cmap for use in avoiding duplicates. */static novalue uniqcolors() { int i, j, r, g, b; for (i = 0; i < MapSize; i++) { r = cmap[i].red; g = cmap[i].green; b = cmap[i].blue; for (j = 0; j < i; j++) /* find lowest match, possibly self */ if (cmap[j].red == r && cmap[j].green == g && cmap[j].blue == b) break; cmap[i].uniq = j; } }/* * setmap(m, c) - set Marked or Unmarked colors to c, according to m, and set * others back to normal. Load the resulting color map into the device. */novalue setmap(m, c)int m, c; { int i, n; n = Marked + Unmarked - m; /* n is opposite of m (Marked or Un) */ for (i = 0; i < NColors; i++) { /* alter map buffer */ cmap[n + i] = cmap[i]; cmap[m + i] = cmap[c]; } devmap(); /* load map into device */ }/* * legend() - display legend */novalue legend() { struct centry *e; int col, n, lum, fg; col = 0; for (e = cdata; e->code; e++) { if (e->code != SpaceCode) { n = e - cdata; lum = 30 * cmap[n].red + 59 * cmap[n].green + 11 * cmap[n].blue; fg = (lum > (100 * 128)) ? C_Black : C_White; mtext(e->label, 1, col, fg, e - cdata); } col += strlen(e->label) + 1; } } :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:memmon Folder:mcolors.h
/* created mechanically -- DO NOT EDIT */ColorDefault("free","111")ColorDefault("coexpr","420")ColorDefault("alien","677")ColorDefault("string","775")ColorDefault("subs","775")ColorDefault("file","670")ColorDefault("refresh","420")ColorDefault("int","753")ColorDefault("real","770")ColorDefault("record","607")ColorDefault("set","400")ColorDefault("selem","700")ColorDefault("list","055")ColorDefault("lelem","077")ColorDefault("table","040")ColorDefault("telem","070")ColorDefault("tvtbl","370")ColorDefault("hash","406")ColorDefault("cset","760")ColorDefault("ext","677")ColorDefault("background","000")ColorDefault("bsep","000")ColorDefault("ssep","700")ColorDefault("marked","111")ColorDefault("unmarked","000")ColorDefault("status","777")ColorDefault("prompt","770")ColorDefault("title","777")ColorDefault("regions","777")ColorDefault("black","000")ColorDefault("grey","111")ColorDefault("white","777")ColorDefault("blink","777") :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:memmon Foldeol.c
/* * mcontrol.c: main control of memory monitoring. */#include "memmon.h"hidden novalue gcmark Params((word n));static units;static pausereply = 0;static initialized = 0;/* * skipgc(n) - skip the first n garbage collections. */novalue skipgc(n)int n; { int b, c; if (gclimit == 0) mquit(NormalExit); b = 0; while (n > 0) { switch (c = getc(ifile)) { case EOF: /* EOF */ fprintf(stderr, "%s: hit EOF while skipping\n", progname); exit(ErrorExit); return; case '#': /* comment */ case ';': /* pause */ while ((c = getc(ifile)) != EOF && c != '\n') ; break; case '{': ncollect++; switch (b - '0') { case 4: /* fall through -- old version of case 0 */ case 0: nexplicit++; break; case 1: nstatic++; break; case 2: nstring++; break; case 3: nblock++; break; } if (ncollect == gclimit) mquit(NormalExit); break; case '}': /* end marking phase */ n--; break; } b = c; } } /* * memmon() - main loop of the memory monitor. */novalue memmon() { int c; word addr, len; int colr; char buf[LineSize]; if (pauselimit == 0) return; for (;;) switch (c = getcmd(&addr, &len)) { case 0: /* 0: end of file; terminate cleanly */ if (!initialized) { fprintf(stderr, "%s: empty input file\n", progname); exit(ErrorExit); } mpause('d', "done"); mstatus("done", C_Status); return; case '#': /* #: comment */ while ((c = getc(ifile)) != EOF && c != '\n') ; break; case '<': /* <: new memory layout */ units = (len > 0) ? len : 4; /* set units if specified */ getregion(&stc); getregion(&str); getregion(&blk); refresh(); /* redraw entire screen */ str.used = 0; /* will recalculate during marking */ blk.used = 0; paintblk(&stc, (word)0, stc.length, C_Free); paintstr((word)0, str.length, C_Free, C_Bsep); paintblk(&blk, (word)0, blk.length, C_Free); if (ncollect > 0) mstatus("compacting", C_Status); initialized = 1; break; case '>': /* >: new layout is complete */ mstatus("running", C_Status); devflush(); break; case '=': /* =: check that we're in sync */ rsync(&stc, "static"); rsync(&str, "string"); rsync(&blk, "blk"); break; case '"': /* ": string allocation */ paintstr(str.used, len, Unmarked + C_String, Unmarked + C_Ssep); str.used += len; break; case '$': /* $: mmshow() of a string */ colr = getshow(); paintstr(addr, len, colr, Unmarked + C_Ssep); break; case 'u': /* u: Tvsubs substring trapped var */ case 'f': /* f: T_File file block */ case 'x': /* x: T_Refresh refresh block */ case 'i': /* i: T_Bignum long integer */ case 'r': /* r: T_Real real number */ case 'R': /* R: T_Record record block */ case 'S': /* S: T_Set set header block */ case 's': /* s: T_Selem set element block */ case 'L': /* L: T_List list header block */ case 'l': /* l: T_Lelem list element block */ case 'T': /* T: Table table header block */ case 't': /* t: Telem table element block */ case 'h': /* h: T_Slots hash buckets (slots) */ case 'e': /* e: Tvtbl table elem trapped var */ case 'E': /* E: T_External external block */ case 'c': /* c: T_Cset cset */ len *= units; paintblk(&blk, blk.used, len, Unmarked + blkcolor[c]); blk.used += len; break; case '%': /* %: mmshow() in the block region */ addr *= units; len *= units; colr = getshow(); paintblk(&blk, addr, len, colr); break; case 'A': /* A: alien block in static region */ case 'F': /* F: free block in static region */ addr *= units; len *= units; paintblk(&stc, addr, len, blkcolor[c]); break; case 'X': /* X: coexpr block in static region */ addr *= units; len *= units; paintblk(&stc, addr, len, Unmarked + blkcolor[c]); break; case 'Y': /* Y: mmshow() in the static region */ addr *= units; len *= units; colr = getshow(); paintblk(&stc, addr, len, colr); break; case ';': /* ;: mmpause() call */ getc(ifile); /* skip space character */ fgets(buf, LineSize, ifile); /* read message */ buf[strlen(buf)-1] = '\0'; /* remove newline */ /* pause unless previous reply said "don't stop again" */ if (pausereply != EOF && pausereply != 'g' && pausereply != 'G') pausereply = mpause('p', buf); break; case '{': /* {: begin marking for garb. coll. */ gcmark(len); break; case '!': /* !: end garbage collection */ gcwait('c', "end garbage collection"); if (ncollect == gclimit) { mstatus("quit", C_Status); mquit(NormalExit); } mstatus("running", C_Status); break; default: fprintf(stderr, "%s: unexpected input char: %c\n", progname, c); exit(ErrorExit); } } /* * gcmark(n) - handle marking phase of garbage collection, reason n. */static novalue gcmark(n)word n; { word addr, len; int c, markflag; char *s; markflag = showmarking; ncollect++; switch ((int)n) { case 4: /* fall through -- old version of case 0 */ case 0: s = "collect(0) call"; nexplicit++; break; case 1: s = "need static space"; nstatic++; break; case 2: s = "need string space"; nstring++; break; case 3: s = "need block space"; nblock++; break; default: s = "g.c. reason lost"; break; } if (gcwait('f', s) == '+') markflag = 0; if (markflag) mstatus("marking", C_Status); for (;;) switch (c = getcmd(&addr, &len)) { case '#': /* #: comment */ while ((c = getc(ifile)) != EOF && c != '\n') ; break; case 0: /* 0: end of file (shouldn't happen) */ case '}': /* }: end marking phase */ if (markflag) do { c = gcwait('g', "marking done, garbage remains"); if (c == EOF || !index(whenpause, 'a')) break; setmap(Unmarked, C_Unmarked); c = gcwait('a', "active data before compaction"); setmap(Marked, C_Marked); } while (c == '-'); return; case '"': /* ": string allocation */ if (markflag) paintstr(addr, len, Marked + C_String, Marked + C_Ssep); break; case 'u': /* u: Tvsubs substring trapped var */ case 'f': /* f: T_File file block */ case 'x': /* x: T_Refresh refresh block */ case 'i': /* i: T_Bignum long integer */ case 'r': /* r: T_Real real number */ case 'R': /* R: T_Record record block */ case 'S': /* S: T_Set set header block */ case 's': /* s: T_Selem set element block */ case 'L': /* L: T_List list header block */ case 'l': /* l: T_Lelem list element block */ case 'T': /* T: Table table header block */ case 't': /* t: Telem table element block */ case 'e': /* e: Tvtbl table elem trapped var */ case 'h': /* h: T_Slots hash buckets (slots) */ case 'E': /* E: T_External external block */ case 'c': /* c: T_Cset cset */ if (markflag) { addr *= units; len *= units; paintblk(&blk, addr, len, Marked + blkcolor[c]); } break; case 'A': case 'F': case 'X': if (markflag) { addr *= units; len *= units; paintblk(&stc, addr, len, Marked + blkcolor[c]); } break; default: fprintf(stderr,"%s: unexpected input char during gc: %c\n",progname,c); exit(ErrorExit); } } :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:memmon Folder:memmon.h
/* * memmon.h: general memmon definitions. */#include "::h:config.h"#include "mproto.h" /* memmmon function prototypes */#include "msymbols.h" /* color labels and definitions */#ifndef Global#define Global extern#endif /* Global *//* * Manifest constants. */#define LineSize 100 /* size for line buffers */#define TextLength 112 /* prompt/legend line size */#define TextLines 2 /* number of such lines */#define StatusLength 35 /* size of the status message */#define RegionLength 35 /* typical max for the region display */#define TitleLength (TextLength - StatusLength - RegionLength)#define SpaceCode '-' /* special code for spacing legend *//* * Command options. */Global char *progname; /* program name, for diagnostics etc. */Global int showmarking; /* show marking phase? */Global int gclimit; /* quit after this many gc's */Global int pauselimit; /* quit after this many pauses */Global char *whenpause; /* when to pause */Global char *whichregs; /* which regions to display */Global char *title; /* display title *//* * Output parameters. Some of these are changeable by command option; * not all devices honor such changes. Others are calculated. */Global int granularity; /* display granularity */Global int sfreq; /* screen frequency for PostScript */Global int width, height; /* output image size, in pixels */Global int textrow; /* output height of a legend box */Global int textsep; /* pixels separating legend from mem */Global int memrow; /* height of one memory row */ /* (can decrease but not increase) */Global int batchmode; /* nonzero if batch mode output */Global int memheight; /* height of the memory region */Global word mempixels; /* total horizontal memory pixels */Global int ymin; /* minimum y value actually used *//* * The current color map, in three sections. * The first section remains constant, once initialized. * The second sections colors unmarked blocks. * The third section colors marked blocks. * Colors in the second and third sections change dynamically during g.c. */#define MapSize (3*NColors) /* color map size */#define Unmarked NColors /* offset to unmarked colors */#define Marked (2*NColors) /* offset to marked colors */Global struct { unsigned char red; /* primary color components 0 - 255 */ unsigned char green; unsigned char blue; unsigned char uniq; /* lowest numbered identical color */ } cmap[MapSize];Global word blkcolor[256]; /* block entry, indexed by key char *//* * Region information. */struct region { word base; /* base address */ word used; /* memory used */ word length; /* region size */ word displ; /* length displayed */ word saddr; /* screen address */ };Global struct region stc; /* static region information */Global struct region str; /* string region information */Global struct region blk; /* block region information *//* * Miscellaneous global variables. */Global word ncollect; /* total garbage collections */Global word nstatic, nstring, nblock, nexplicit; /* region totals */Global FILE *ifile; /* input file */Global FILE *ttyi, *ttyo; /* tty file for prompts & acks *//* * Redefinitions */ :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:memmon Folder:mgrays.h
/* created mechanically -- DO NOT EDIT */ColorDefault("free","111")ColorDefault("coexpr","222")ColorDefault("alien","666")ColorDefault("string","777")ColorDefault("subs","777")ColorDefault("file","666")ColorDefault("refresh","222")ColorDefault("real","777")ColorDefault("record","333")ColorDefault("set","333")ColorDefault("selem","555")ColorDefault("list","222")ColorDefault("lelem","444")ColorDefault("table","222")ColorDefault("telem","666")ColorDefault("tvtbl","444")ColorDefault("cset","555")ColorDefault("ext","666")ColorDefault("background","000")ColorDefault("bsep","000")ColorDefault("ssep","333")ColorDefault("marked","000")ColorDefault("unmarked","000")ColorDefault("status","777")ColorDefault("prompt","777")ColorDefault("title","777")ColorDefault("regions","777")ColorDefault("black","000")ColorDefault("grey","222")ColorDefault("white","777")ColorDefault("blink","777") :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:memmon Folder:minput.c
/* * minput.c: input routines. */#include <ctype.h>#include "memmon.h"static word previous[256]; /* previous length, indexed by input char *//* * getcmd(&addr, &len) - get next command, returning key character. */int getcmd(addr, len)word *addr, *len; { int c; word n; c = getc(ifile); while (isspace(c)) c = getc(ifile); if (c == EOF) return 0; if (isdigit(c)) { n = c - '0'; while (isdigit(c = getc(ifile))) n = 10 * n + c - '0'; if (c == '+') { c = getcmd(addr, len); *addr = n; } else { *addr = -1; *len = n; previous[c] = n; } } else { *addr = -1; *len = previous[c]; } return c; }/* * getshow() - get the color for an mmshow() command. * * An mmshow command is followed by two characters "ct"; c is the color * character passed to mmshow(), and t is the type of the item. */word getshow() { int c, t; c = getc(ifile); t = getc(ifile); switch (c) { case 'b': return Unmarked + C_Black; case 'g': return Unmarked + C_Grey; case 'h': return Unmarked + C_Blink; case 'r': return Unmarked + blkcolor[t]; case 'w': return Unmarked + C_White; default: return Unmarked + C_Blink; } }/* * getregion() - get region information (base, used, length for one region). */novalue getregion(rgn)struct region *rgn; { word addr; getcmd(&addr, &rgn->base); getcmd(&addr, &rgn->used); getcmd(&addr, &rgn->length); }/* * rsync() - region synchronization (sanity check). * * Rsync reads region information and compares it with what we already know. * A discrepancy indicates a program bug or corrupted data file. */novalue rsync(rgn, label)struct region *rgn;char *label; { struct region r; getregion(&r); if (r.base != rgn->base || r.used != rgn->used || r.length != rgn->length) { fprintf(stderr, "%s internal error: out of sync: %s region\n", progname, label); fprintf(stderr, "expected %ld:%ld/%ld, got %ld:%ld/%ld\n", rgn->base, rgn->used, rgn->length, r.base, r.used, r.length); exit(ErrorExit); } } :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:memmon Folder:mkclr.icn
# Icon program to preprocess color specification file into C macrosprocedure main () ws := ' \t' write ("/* created mechanically -- DO NOT EDIT */") write () while line := read () do line ? { tab (many (ws)) if ="#" | pos (0) then next # skip comment line label := tab (upto (ws)) | next tab (many (ws)) if pos (0) then next value := tab (upto (ws) | 0) write ("ColorDefault(\"", label, "\",\"", value, "\")") } end :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:memmon Folder:mksym.icn
# Icon program to preprocess color symbol and label definitions into Crecord colr (sym, char, label)procedure main () colors := [] err := 0 ws := ' \t' while line := read () do line ? { tab (many (ws)) if ="#" | pos (0) then next # skip comment line sym := tab (upto (ws) | 0) tab (many (ws)) char := tab (upto (ws) | 0) tab (many (ws)) label := tab (upto (ws) | 0) if *label > 0 then put (colors, colr (sym, char, label)) else { write (&errout, "bad input:\t", line) err +:= 1 } } if err > 0 then stop ("output suppressed due to input errors") write ("/* created mechanically -- DO NOT EDIT */") write () write ("#ifndef NColors"); every i := 1 to *colors do write ("#define ", left (colors[i].sym, 12), right (i-1, 3)) write ("#define NColors ", *colors) write ("#endif\t\t\t\t/* NColors */"); write () write ("#ifdef Color"); every i := 1 to *colors do write ("Color(",colors[i].sym,",",colors[i].char,",",colors[i].label,")") write ("#endif\t\t\t\t/* Color */"); end :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:memmon Folder:mmaed.c
/* * mmaed.c: graphics driver for AED 1024. * * The AED is a 1024 x 768 x 8 color display with an 8+8+8 bit lookup table. * * For reasons of speed, this driver writes all blocks one pixel high * using a runlength encoding. Hardware zoom (vertically only) is used * to make the display look reasonable. This all works well and does * speed things up quit a bit, but it means we can't write any text, * so there's no legend on the display. */#include <varargs.h>#include "memmon.h"hidden novalue aedcmd Params((/*varargs*/));#define VSize 768 /* vertical screen size */#define HSize 1024 /* horizontal screen size */#define EndRun() if(runaddr)putchar(runaddr=0) /* end a run of pixels */static runaddr = 0; /* curr addr if pixel run in progress *//* * devsetup() - set globals to device-dependent values. */novalue devsetup() { granularity = 4; width = HSize; height = VSize; textrow = 0; /* no legend */ textsep = 0; /* so no separating line */ memrow = 16; }/* * devinit() - initialize for graphics output. */novalue devinit() { static char obuf[BUFSIZ]; /* small buffer for smoother output */ if (height != VSize || width != HSize || textrow > 0) { fprintf(stderr, "%s: -h, -w, -L ignored\n", progname); height = VSize; width = HSize; textrow = 0; } if (memrow > 16) { fprintf(stderr, "%s: -M limited to 16\n", progname); memrow = 16; /* hardware limit */ } litout(); /* set literal output mode if a tty */ setbuf(stdout, obuf); /* set small, local buffer */ fputs("\033SEN18D88", stdout); /* set encoding mode to binary */ aedcmd("gii", 0, 767); /* set normal window boundaries */ aedcmd("4bbbbbb", Unmarked + C_Blink, 0, 0, 0, 20, 20); /* blink C_Blink with black */ }/* * devmap() - load color map into device. */novalue devmap() { int i; EndRun(); aedcmd("Kbb", 0, MapSize); for (i = 0; i < MapSize; i++) { putchar(cmap[i].red); putchar(cmap[i].green); putchar(cmap[i].blue); } }/* * devflood(c) - fill screen with color c. */novalue devflood(c)int c; { EndRun(); aedcmd("Ebb", 1, memrow); /* set zoom for y scaling (only!) */ aedcmd("[b", c); /* set background color */ aedcmd("~"); /* erase screen (kills scaling) */ aedcmd("Ebb", 1, memrow); /* reset scaling */ }/* * devpaint(start, n, color, b) - paint n pixels in given color. * If b >= 0, the last pixel is to be that color instead (for a border) */novalue devpaint(s, n, c, b)word s, n;int c, b; { if (runaddr && runaddr != s) putchar(runaddr = 0); if (!runaddr) { aedcmd("Qx", s % HSize, VSize - 1 - s / HSize); aedcmd("s"); } runaddr = s + n; if (b >= 0) n--; while (n > 254) { putchar(254); putchar(c); n -= 254; } if (n > 0) { putchar(n); putchar(c); } if (b >= 0) { putchar(1); putchar(b); } }/* * devtext(string, row, col, fgcolr, bgcolr) - don't output text. * (We can't output any text due to the mode we've put the AED in.) * (So, with textrow=0, this shouldn't ever be called, but is needed to link.) *//*ARGSUSED*/novalue devtext(s, r, c, f, b)char *s;int r, c, f, b; { }/* * devsnap() - batch mode snapshot; no action needed here. */novalue devsnap() { }/* * devflush() - flush output. */novalue devflush() { EndRun(); fflush(stdout); }/* * devterm() - terminate graphics. */novalue devterm() { EndRun(); aedcmd("Gs", "3DNNN"); /* reset encoding */ aedcmd("\r"); /* exit graphics mode */ } /* * aedcmd(s, args) - output command to the AED. * s is a string specifying the command format a la printf. The first * character (or two chars if first is '+') are the AED command. * Additional characters specify formats for outputting additional * arguments (see below). *//*VARARGS1*/static novalue aedcmd (s, va_alist)char *s;va_dcl { va_list ap; char c; unsigned int n, x, y; va_start(ap); if (putchar(*s++) == '+') putchar(*s++); while (c = *s++) switch (c) { /* Output formats for add'l args: */ case 'b': /* b - single byte unaltered */ case 'c': /* c - single char unaltered */ n = va_arg(ap, int); putchar(n); break; case 'i': /* i - 16-bit integer as two bytes */ n = va_arg(ap, int); putchar(n>>8); putchar(n); break; case 's': /* s - string terminated by '\0' */ fputs(va_arg(ap, char*), stdout); break; case 'x': /* x - two args give x and y coords */ x = va_arg(ap, int); y = va_arg(ap, int); putchar(((x >> 4) & 0xF0) | (y >> 8)); putchar(x); putchar(y); break; default: /* unrecognized - just echoed */ putchar(c); } va_end(ap); } :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:memmon Folder:mmain.c
/* * mmain.c: code shared among memmon back ends. *//* in this file only, define globals instead of just declaring */#define Global#include "memmon.h"hidden novalue mmoptions Params((int argc, char *argv[]));hidden novalue mmusage Params((noargs));static int justcolors = 0; /* quit after setting colors? */static int gcskip = 0; /* number of gc's to skip *//* * main program. */novalue main(argc, argv)int argc;char *argv[]; { progname = argv[0]; /* save program name for diagnostics */ devsetup(); /* init device-dependent params */ initcolors(); /* init color tables */ mmoptions(argc, argv); /* process command options */ devinit(); /* open and initialize device */ if (justcolors) { /* if just color setting wanted: */ setmap(Marked, C_Marked); /* load color map */ mquit(NormalExit); /* terminate */ } if (strcmp(whenpause,"") != 0 && strcmp(whenpause,"n") != 0 && !batchmode) { ttyi = fopen("/dev/tty", "r"); /* init tty input file */ ttyo = fopen("/dev/tty", "w"); /* init tty output file */ if (ttyi == NULL || ttyo == NULL) { fprintf(stderr, "%s: can't open /dev/tty; will not pause\n", progname); ttyi = ttyo = NULL; } } skipgc(gcskip); /* skip the first n collections */ memmon(); /* run the memory monitor */ mquit(NormalExit); /* terminate */ } /* * mmoptions(argc, argv) - process command options. */static novalue mmoptions(argc, argv)int argc;char *argv[]; { int c; extern char *optarg; /* getopt() */ extern int optind; /* getopt() */ /* * set some defaults */ gclimit = -1; /* no limit on gc's */ pauselimit = -1; /* no limit on pauses */ whichregs = "sb"; /* regions */ if (batchmode) whenpause = "fgacpd"; /* pause/print points */ else whenpause = "fgacp"; /* pause/print points */ /* * We should ideally keep the next two lines in sync! * Unfortunately, there are too many options to include all in synopsis. */#define MMUse "[-r {fsb}] [-p {fgacpdn}] [-bwhLMgqQS n] [-t title] [...] [file]" while ((c = getopt(argc, argv, "r:p:b:w:h:L:M:g:q:Q:S:t:mc:C:")) != EOF) switch (c) { case 'r': whichregs = optarg; break; case 'p': whenpause = optarg; break; case 'b': granularity = atoi(optarg); break; case 'w': width = atoi(optarg); break; case 'h': height = atoi(optarg); break; case 'L': textrow = atoi(optarg); break; case 'M': memrow = atoi(optarg); break; case 'g': gcskip = atoi(optarg); break; case 'q': gclimit = atoi(optarg); break; case 'Q': pauselimit = atoi(optarg); break; case 'S': sfreq = atoi(optarg); break; case 't': title = optarg; break; case 'm': showmarking = 1; break; case 'c': readcolors(optarg); break; case 'C': justcolors = 1; readcolors(optarg); break; default: mmusage(); } if (index(whenpause, 'g') || index(whenpause, 'a')) showmarking = 1; /* show marking if going to pause */ if (optind + 1 < argc) /* if too many files named, quit */ mmusage(); if (optind < argc) { /* open input file, if specified */ ifile = fopen(argv[optind], "r"); if (!ifile) pexit(argv[optind]); if (!title) title = argv[optind]; /* use file name as default title */ } else /* else use standard input */ ifile = stdin; } /* * mmusage() - diagnose bad memmon usage, and abort. */static novalue mmusage() { fprintf(stderr, "usage: %s %s\n", progname, MMUse); exit(ErrorExit); }/* * mquit(exitcode) - terminate the run. */novalue mquit(exitcode)int exitcode; { devterm(); /* close down the graphics device */ exit(exitcode); } :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:memmon Folder:mmmeta.c
/* * mmmeta.c: batch mode metafile(5) translator. */#include "memmon.h"hidden novalue mffhex Params((unsigned char *p, int x, int y, int w, int h));hidden novalue mffcolor Params((int c, char *text));#define CharHeight (textrow / 2) /* height of a text char */#define CharBase (textrow / 5) /* offset to baseline within text box */#define CharProp ((150 * width) / (TextLength * CharHeight)) /* proportionality */static char hexo[MapSize][4]; /* color map entries as 3 hex chars *//* * devsetup() - set globals to device-dependent values. */novalue devsetup() { granularity = 4; width = 912; height = 630; textrow = 20; textsep = 2; memrow = 20; batchmode = 1; }/* * devinit() - initialize output file. */novalue devinit() { char time_buf[26]; getctime(time_buf); printf("%% Icon MemMon snapshots\n"); if (title) printf("%% %s\n", title); printf("%% %s", time_buf); printf("\n"); printf("1 metafile\n"); }/* * batbegin() - prepare to write an image. */novalue batbegin() { int i; for (i = 0; i < MapSize; i++) { /* init hex color map */ hexo[i][0] = "0123456789ABCDEF"[cmap[i].red>>4]; hexo[i][1] = "0123456789ABCDEF"[cmap[i].green>>4]; hexo[i][2] = "0123456789ABCDEF"[cmap[i].blue>>4]; } printf("\n%d %d ", width-1, height-1); mffcolor(C_Background, "init\n"); /* start new page/frame/etc. */ if (textrow > 0) printf("%d %d 100 (Helvetica) font\n", CharHeight, CharProp); }/* * battext(s, row, col, fg, bg) - output tex. */novalue battext(s, row, col, fg, bg)char *s;int row, col, fg, bg; { float charwidth; int x, xx, y; charwidth = (float)width / (float)TextLength; x = charwidth * col; xx = charwidth * (col + strlen(s) + 1); y = height - (row + 1) * textrow + 1; mffcolor(bg, "color "); printf("%d %d begin %d %d line %d %d line %d %d line fill\n", x, y, x, y + textrow - 2, xx - 2, y + textrow - 2, xx - 2, y); x += charwidth / 2; y += CharBase; mffcolor(fg, "color "); printf("%d %d ", x, y); pstext(s); printf(" text\n"); }/* * batmem(mbuf) - output memory image. */novalue batmem(mbuf)unsigned char mbuf[]; { word n; int w, y; y = memheight; n = mempixels; while (n > 0 && (y -= memrow) >= 0) { w = (n > width) ? (word)width : n; /* the cast above avoids a Lightspeed C 2.0 bug */ mffhex(mbuf, 0, y, w, memrow-1); mbuf += w; n -= w; } }/* * batterm() - terminate entire run. (Nothing to do.) */novalue batterm() { }/* * mffcolor(c, text) - output mff color spec, then the text. */static novalue mffcolor(c, text)int c;char *text; { printf("%3d %3d %3d %s", cmap[c].red, cmap[c].green, cmap[c].blue, text); }/* * mffhex(buf, x, y, w, h) - output one line of raster data in hex. */static novalue mffhex(buf, x, y, w, h)unsigned char *buf;int x, y, w, h; { register int i; register char *o; register unsigned char *p, *q; /* * Check for a line that's all the same color, and output more compactly. */ p = buf; i = *p; for (q = p + w; q > p && *--q == i; ) ; if (q == p) { printf("%d %d %d %d 1 1 -4 raster\n%s0\n", x, y, w, h, hexo[i]); return; } /* * Optimization failed. Output line in detail. */ printf("%d %d %d %d %d 1 -4 raster", x, y, w, h, w); for (i = 0; i < w; i++) { if ((i & 31) == 0) putchar('\n'); o = hexo[*p++]; putchar(*o++); /* red */ putchar(*o++); /* green */ putchar(*o); /* blue */ } if (w % 2) putchar('0'); /* must have an even number of hex digits per raster */ putchar('\n'); } :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:memmon Folder:mmps.c
/* * mmps.c: batch mode PostScript translator. * * We define and use four general procedures: * oldy oldx y x n -R- y x+n+1 % n by H rectangle at (x,y), set x & y * oldy oldx n -A- oldy oldx+n+1 % n by H rectangle adjacent, update x * oldy oldx -V- oldy oldx % 1 by H rectangle at left, no change * text x y -S- -- % text string at (x,y) * We also define a Cnn procedure for each different color used. * * "S" is straightforward and simply displays a text string. The other three * general procedures work together to fill rectangles. They maintain current * y and x values atop the PostScript stack. x is atop y for easiest access. * * "R" draws an n-wide block at (x,y), leaving (x+n+1, y) on the stack. The +1 * allows for the usual one-pixel gap between blocks on the display. * * "A" draws an n-wide block adjacent to the last block, updating the stack * similarly. * * "V" draws a 1-wide block to the LEFT of the stack location, leaving it * unchanged. This is designed for drawing string-region separators. */#include "memmon.h"hidden novalue rect Params((int c, int x, int y, int n));hidden novalue pscolor Params((int c));#define PageHeight 792 /* default dimensions */#define PageWidth 612#define SideMargin 72 /* 1" margin at top and sides */#define TopMargin 72#define BotMargin 96 /* larger at bottom for QMS color ptr */#define MaxHeight (PageHeight - TopMargin - BotMargin)#define MaxWidth (PageWidth - 2 * SideMargin)#define FrameWidth 1 /* frame surrounding dimensions above */#define Font "Helvetica"#define CharHeight (3 * textrow / 4) /* height of a text char */#define CharBase (textrow / 4) /* offset to baseline within text box */static int llx, lly, urx, ury; /* bounding box including frame */static int xcur, ycur; /* current y, x on PostScript stack */static float psscale; /* output scaling */static int lastpscolor = -1; /* last color command output *//* * devsetup() - set globals to device-dependent values. */novalue devsetup() { granularity = 4; width = MaxWidth; height = MaxHeight; textrow = 11; textsep = 2; memrow = 20; batchmode = 1; }/* * devinit() - initialize output file. */novalue devinit() { char time_buf[26]; int fwidth, fheight, i; fheight = height + 2 * FrameWidth; /* dimensions including frame */ fwidth = width + 2 * FrameWidth; psscale = 1.0; if (width > MaxWidth) psscale = (MaxWidth) / (float)width; if (psscale * height > MaxHeight) psscale *= (MaxHeight) / (psscale * height); llx = (PageWidth - psscale * fwidth) / 2; lly = PageHeight - TopMargin - psscale * fheight; urx = llx + psscale * fwidth + 0.999; ury = lly + psscale * fheight + 0.999; getctime(time_buf); printf("%%!PS-Adobe-2.0 EPSF-1.2\n"); if (title) printf("%%%%Title: %s\n", title); printf("%%%%Creator: mmps\n"); printf("%%%%CreationDate: %s", time_buf); printf("%%%%DocumentFonts: %s\n", Font); printf("%%%%BoundingBox: %d %d %d %d\n", llx, lly, urx, ury); printf("%%%%EndComments\n"); /* * define general-purpose PostScript procedures */ printf("/R { 5 3 roll pop pop 3 copy add exch moveto 0 H rlineto\n"); printf(" dup neg 0 rlineto 0 H neg rlineto fill add 1 add } bind def\n"); printf("/A { 3 copy add exch moveto 0 H rlineto\n"); printf(" dup neg 0 rlineto 0 H neg rlineto fill add 1 add } bind def\n"); printf("/V { 2 copy exch moveto 0 H rlineto\n"); printf(" -1 0 rlineto 0 H neg rlineto fill } bind def\n"); printf("/S { moveto show } bind def\n"); /* * define a procedure for each unique color */ for (i = 0; i < NColors; i++) if (cmap[i].uniq == i) /* if first occurrence */ printf("/C%d { %.2f %.2f %.2f setrgbcolor } bind def\n", i, cmap[i].red / 255.0, cmap[i].green / 255.0, cmap[i].blue / 255.0); printf("%%%%EndProlog\n"); }/* * batbegin() - prepare to write an image. */novalue batbegin() { static int pageno = 0; int x; float yscale; ++pageno; lastpscolor = -1; /* initialize for a new page */ printf("%%%%Page: %d %d\n", pageno, pageno); printf("save\n"); if (sfreq != 0) printf("currentscreen 3 -1 roll pop %d 3 1 roll setscreen\n", sfreq); /* scale according to global parameters set up earlier */ printf("%d %d translate\n", llx, lly); printf("%f %f scale\n", psscale, psscale); printf("%d %d translate\n", FrameWidth, FrameWidth); /* move inside border */ /* tweak the scaling a little more to fill up unused space at the bottom */ yscale = (float)(height + 2 * FrameWidth) / (height - ymin + 2 * FrameWidth); printf("0 %d translate\n", height + FrameWidth); printf("1.0 %f scale\n", yscale); printf("0 %d translate\n", -height - FrameWidth); /* draw the background, a rectangle with the last partial line reomved */ pscolor(C_Background); printf("\n"); x = mempixels % width; if (x == 0) x = width; printf("%d %d moveto %d %d lineto %d %d lineto %d %d lineto\n", -FrameWidth, ymin - FrameWidth, -FrameWidth, height + FrameWidth, width + FrameWidth, height + FrameWidth, width + FrameWidth, ymin - FrameWidth + memrow); printf(" %d %d lineto %d %d lineto fill\n", x + FrameWidth, ymin - FrameWidth + memrow, x + FrameWidth, ymin - FrameWidth); /* finish initialization */ printf("1 setlinewidth\n"); if (textrow > 0) { printf("/%s findfont [%.3f 0 0 %.3f 0 0] makefont setfont\n", Font, 1.9 * (float)width / (float)TextLength, (float)CharHeight); printf("/H %d def\n", textrow - 1); } printf("0 0\n"); /* initial y,x for the PostScript stack */ xcur = ycur = 0; }/* * battext(s, row, col, fg, bg) - output text string. */novalue battext(s, row, col, fg, bg)char *s;int row, col, fg, bg; { float charwidth; int x, xx, y; charwidth = (float)width / (float)TextLength; x = charwidth * col; xx = charwidth * (col + strlen(s) + 1); y = height - (row + 1) * textrow + 1; rect(bg, x, y, xx - x - 1); pscolor(fg); pstext(s); printf(" %d %d S\n", (int)(x + charwidth / 2), y + CharBase); } /* * batmem(mbuf) - output memory image. */novalue batmem(mbuf)unsigned char mbuf[]; { int c, d, n, x, y; unsigned char *p, *endrow, *endmem; if (memrow > 1) printf("/H %d def\n", memrow - 1); /* define row height */ else printf("/H 1 def\n"); /* * identify contiguous blocks of color * (assumes we can skip the separator pixel between two blocks) */ p = mbuf; endmem = mbuf + mempixels; y = memheight; while (p < endmem) { endrow = p + width; if (endrow > endmem) endrow = endmem; x = -1; y -= memrow; while (p < endrow) { c = *p++; x++; if (c == C_Bsep) continue; n = 1; while (p < endrow && (d = *p++) == c) n++; rect(c, x, y, n); /* fill rectangle with color c */ x += n; if (d != C_Bsep && p < endrow) p--, x--; } } printf("pop pop restore showpage\n"); } /* * batterm() - terminate entire run. */novalue batterm() { printf("%%%%Trailer\n"); }/* * rect(c,x,y,n) - fill an H by n rectangle at (x,y) with color c. */static novalue rect(c, x, y, n)int c, x, y, n; { pscolor(c); if ((n == 1) && (x == xcur - 1) && (y == ycur)) printf("V\n"); else if ((x == xcur) && (y == ycur)) { printf("%d A\n", n); xcur = x + n + 1; } else { printf("%d %d %d R\n", y, x, n); xcur = x + n + 1; ycur = y; } }/* * pscolor(c) - write a setcolor command for color c, * if it's not the same as the last one. */static novalue pscolor(c)int c; { c = cmap[c].uniq; if (lastpscolor == c) return; printf("C%d ", c); lastpscolor = c; } :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:memmon Folder:mmrt.c
/* * mmrt.c: graphics driver for Raster Tech One/80. * * This Raster Tech unit is a 1280 x 1024 x 24 color display, where * the 8 bits of each color plane are interpreted through a lookup table. * We use it as if it were 1280 x 1024 x 8 display, with lookup. */#include <varargs.h>#include "memmon.h"hidden novalue rtcmd Params((/*varargs*/));#define HSize 1280 /* horizontal screen size */#define VSize 1024 /* vertical screen size */#define CTAddr 0xFC00 /* color table address in raster tech *//* raster tech command bytes and formats */#define SGPX "\004" /* enter graphics (standard) */#define EGPX "\005" /* enter graphics (redef from \004) */#define BLINKC "\043"#define BLINKE "\040bbbb"#define BLINKR "\042b"#define CLEAR "\207"#define CONFIG "\044wwwwwwww"#define DRW3R "\203bb"#define LUT8 "\034bbbb"#define MOVABS "\001xy"#define PIXFUN "\073b"#define POKE "\276ww"#define PRMFIL "\037b"#define QUIT "\377"#define RECREL "\211xy"#define RGBTRU "\116b"#define SCRORG "\066xy"#define SPCHAR "\262bbb"#define TEXTN "\251bbww"#define TEXT1 "\220b"#define VAL8 "\206b"#define VECPAT "\056w"#define WINDOW "\072xyxy"#define WMSK16 "\104w"#define ZOOM "\064b"static int xll, yll; /* screen coordinates of LL corner *//* * devsetup() - set globals to device-dependent values. */novalue devsetup() { granularity = 2; width = HSize; height = VSize; textrow = 20; textsep = 6; memrow = 20; } /* * devinit() - initialize for graphics output. */novalue devinit() { static char obuf[BUFSIZ]; /* small buffer for smoother output */ int xsize, ysize; if (height > VSize) /* limit height to maximum */ height = VSize; if (width > HSize) /* similarly for width */ width = HSize; xll = - width / 2; /* center horizontally */ yll = (VSize / 2) - height; /* move to top of screen */ litout(); /* set literal output mode if tty line*/ setbuf(stdout, obuf); /* use small buffer -- less jerky */ putchar(0); /* try to flush incomplete commands */ putchar(0); putchar(0); putchar(0); rtcmd(QUIT); /* exit graphics mode */ rtcmd(SGPX); /* enter gpx mode, if not yet redef */ rtcmd(SPCHAR, 0, 1, *EGPX); /* redefine from \04 to \05 */ rtcmd(QUIT); /* exit graphics mode */ rtcmd(EGPX); /* enter graphics mode (for sure) */ rtcmd(CONFIG, 0x2000, 0x400, 0x800, 0x1000, 0x400, 0, 0, 0); /* configure memory */ rtcmd(RGBTRU, 1); /* use 24-bit mode */ rtcmd(ZOOM, 1); /* reset zoom */ rtcmd(SCRORG, 0, 0); /* set screen origin */ rtcmd(WINDOW, -HSize / 2, -VSize / 2, HSize / 2 - 1, VSize / 2 - 1); /* set clipping window */ rtcmd(PRMFIL, 1); /* set filled primitives */ rtcmd(VECPAT, 0xFFFF); /* set solid lines */ rtcmd(PIXFUN, 0); /* set opaque mode */ rtcmd(WMSK16, 0xFFFF); /* enable all bit planes */ /* set text paramaters. constants were empirically determined. */ xsize = 2.6 * width / TextLength; ysize = 1.6 * textrow; rtcmd(TEXTN, xsize, ysize, 0, 0); /* set text parameters */ rtcmd(BLINKC); /* clear blink table */ rtcmd(BLINKR, 20); /* set blink rate (1.5 Hz) */ rtcmd(BLINKE, 7, Unmarked + C_Blink, 0, 255); /* blink black/white */ } /* * devmap() - load color map into device. Also write a shadow copy of the map * in high Raster Tech memory for use by rtscreen(1). */novalue devmap() { int i; for (i = 0; i < MapSize; i++) rtcmd(LUT8, i, cmap[i].red, cmap[i].green, cmap[i].blue); for (i = 0; i < MapSize; i += 2) { rtcmd(POKE, CTAddr + i, (cmap[i].red << 8) | cmap[i+1].red); rtcmd(POKE, CTAddr + i + 256, (cmap[i].green << 8) | cmap[i+1].green); rtcmd(POKE, CTAddr + i + 512, (cmap[i].blue << 8) | cmap[i+1].blue); } }/* * devflood(c) - fill screen with color c. */novalue devflood(c)int c; { rtcmd(VAL8, c); /* set color for clear */ rtcmd(CLEAR); /* clear screen */ }/* * devpaint(start, n, color, b) - paint n pixels in given color. * If b >= 0, the last pixel is to be that color instead (for a border) */novalue devpaint(s, n, c, b)word s, n;int c, b; { int x, y; if (b >= 0) /* if border, decr total count*/ n--; x = s % width; /* where on row, which row? */ y = memheight - memrow * (1 + s / width); rtcmd(VAL8, c); /* set color */ while (x + n >= width) { /* draw all rows but last */ rtcmd(MOVABS, xll + x, yll + y); /* position to LL corner */ rtcmd(RECREL, width - 1 - x, memrow - 1 - 1); /* draw to UR corner */ n -= width - x; /* decr count */ x = 0; /* move to start of next row */ y -= memrow; } if (n) { /* last row */ rtcmd(MOVABS, xll + x, yll + y); /* position */ rtcmd(RECREL, n - 1, memrow - 1 - 1); /* draw */ x += n; } if (b >= 0) { /* border */ rtcmd(VAL8, b); /* color */ rtcmd(MOVABS, xll + x, yll + y); /* position */ rtcmd(DRW3R, 0, memrow - 1 - 1); /* draw */ } }/* * devtext(string, row, col, fgcolr, bgcolr) - output text. */novalue devtext(s, row, col, fg, bg)char *s;int row, col, fg, bg; { int x, y, n; float charwidth; charwidth = (float)width / (float)TextLength; n = strlen(s); x = col * charwidth; /* where on line? */ y = height - textrow * (row + 1) + 1; /* which line? */ rtcmd(VAL8, bg); /* set bkground color */ rtcmd(MOVABS, xll + x, yll + y); /* position */ rtcmd(RECREL, (int)(charwidth * (n + 1)) - 2, textrow - 2); /* draw background */ if (fg == bg || n == 0) /* if no text */ return; rtcmd(VAL8, fg); /* set text color */ rtcmd(MOVABS, xll + x + (int)(.45*charwidth), yll + y + (int)(.25*textrow)); rtcmd(TEXT1, n); /* issue text func */ while (*s) putchar(*s++); /* send the chars */ }/* * devsnap() - batch mode snapshot; no action needed here. */novalue devsnap() { }/* * devflush() - flush output. */novalue devflush() { if (stdout->_cnt & 1) /* ugh! */ putchar(0); /* make byte count even */ fflush(stdout); }/* * devterm() - terminate graphics */novalue devterm() { rtcmd(SPCHAR, 0, 1, *SGPX); /* reset "enter graphics" character */ rtcmd(QUIT); /* exit graphics mode */ putchar(0); /* dma driver requires "some" nulls */ putchar(0); putchar(0); putchar(0); putchar(0); putchar(0); devflush(); /* flush output */ }/* * rtcmd(s, args) - output command to raster tech. * s is a string specifying the command format. The first character is a * raster tech function code. Each additional character specifies the format * for outputting one more argument (see below). *//*VARARGS1*/static novalue rtcmd(s, va_alist)char *s;va_dcl { va_list ap; char c; unsigned int n; va_start(ap); /* set up varargs stuff */ putchar(*s++); /* output function byte */ while (c = *s++) switch (c) { /* format characters are: */ case 'b': /* b - output byte */ n = va_arg(ap, unsigned int); putchar(n); break; case 'w': /* w - output word */ case 'x': /* x - output x-coordinate */ case 'y': /* y - output y-coordinate */ n = va_arg(ap, unsigned int); putchar(n >> 8); putchar(n); break; } } :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:memmon Folder:moutput.c
/* * moutput.c: device-independent output routines. */#include "memmon.h"/* * Prototypes. */hidden novalue setdisp Params((struct region *r, int key, word addr));hidden novalue mpaint Params((word addr, word len, int c1, int c2));static int oldscale = 0; /* previous output scaling */static int npauses = 0;static int reply = 0;/* * refresh() - redraw screen, initially or after garbage collection. */novalue refresh() { word nbytes, newpixels; int newrows, newscale; char sbuf[50]; /* set display parameters for each region */ setdisp(&stc, 'f', (word)0); setdisp(&str, 's', stc.saddr + stc.displ); setdisp(&blk, 'b', str.saddr + str.displ); if (textrow > 0) memheight = height - (TextLines * textrow) - textsep + 1; else memheight = height; /* calc total number of bytes */ nbytes = stc.displ + str.displ + blk.displ; if (stc.displ + str.displ + blk.displ == 0) { fprintf(stderr, "%s: no regions selected\n", progname); exit(ErrorExit); } /* calc ideal scaling */ newpixels = (nbytes + granularity - 1) / granularity; newrows = (newpixels + width - 1) / width; newscale = memheight / newrows; /* set scaling, but no more than device or command option maximum */ if (memrow > newscale) memrow = newscale; if (memrow <= 0) /* sanity check, and extreme case */ memrow = 1; if (newrows > memheight) newrows = memheight; /* set total number of pixels and minimum y value */ mempixels = (word)newrows * (word)width; if (mempixels > newpixels) mempixels = newpixels; ymin = memheight - newrows * memrow; if (ymin < 0) ymin = 0; /* if layout has changed (including first time), redraw everything */ if (memrow != oldscale) { devflood(C_Background); /* clear screen */ if (oldscale == 0) setmap(Marked, C_Marked); /* init color map if first time */ legend(); /* replace legend */ if (title) /* display centered title, if any */ mtext(title, 0, 0 + StatusLength + (TitleLength - strlen(title)) / 2, C_Title, C_Background); } oldscale = memrow; /* display region sizes and garbage collection counts */ sprintf(sbuf, "%ld + %ld + %ld (%ld+%ld+%ld+%ld)", (long)stc.length, (long)str.length, (long)blk.length, (long)nstatic, (long)nstring, (long)nblock, (long)nexplicit); mtext(sbuf, 0, TextLength - strlen(sbuf) - 1, C_Rsizes, C_Background); } /* * setdisp(region, key, addr) - set display parameters for a region. */static novalue setdisp(r, key, addr)struct region *r;int key;word addr; { r->saddr = addr; /* set screen address */ if (index(whichregs, key)) r->displ = r->length; /* if displayed, set length */ else r->displ = 0; /* else set to zero */ }/* * paintblk(region, addr, len, color) - show a block. */novalue paintblk(r, addr, len, color)struct region *r;word addr, len;int color; { if (r->displ == 0) return; mpaint((r->saddr + addr) / granularity, len / granularity, color, C_Bsep); }/* * paintstr(addr, len, color1, color2) - show n string bytes. * Each pixel on the display represents multiple bytes. A pixel in which any * string ends will be color2; pixels corresponding to nonterminal characters * of one string will be color1. This method makes long strings individually * distinguishable from each other and from runs of short strings, and allows * continuous output with no backtracking as the string space is allocated. */novalue paintstr(addr, len, color1, color2)word addr, len;int color1, color2; { word s, e; if (str.displ == 0) /* if not displaying strings, return */ return; /* the start pixel is the first pixel wholly owned by this string */ /* the end pixel is the last pixel even partially reached */ s = (str.saddr + addr + granularity -1) / granularity; /* start */ e = (str.saddr + addr + len - 1) / granularity; /* end */ if (e >= s) /* if any new pixels*/ mpaint(s, e - s + 1, color1, color2); }/* * mpaint(addr, len, colr1, colr2) - paint a block or a string. * * Just checks limits, then calls the device-dependent paint routine. */hidden novalue mpaint(addr, len, color1, color2)word addr, len;int color1, color2; { if (addr < 0 || addr >= mempixels || len <= 0) return; /* if out of range, return */ if (addr + len > mempixels) len = mempixels - addr; /* set length to stay within bounds */ devpaint(addr, len, color1, color2); /* paint the device */ }/* * gcwait(key, msg) - pause with garbage collection message. * * Skips the pause if a -p option didn't include the given key character. * After one EOF or 'G', never pauses again. Returns whatever pause returns. */int gcwait(key, msg)int key;char *msg; { if (reply != EOF && reply != 'g' && reply != 'G') reply = mpause(key, msg); return reply; }/* * mpause(key, msg) - pause for response (or, in batchmode, print display). * * Skips the pause if a -p option didn't include the given key character. * Returns the last character before '\n', 0 if none, or EOF. */int mpause(key, msg)int key;char *msg; { static int c1, c2; if (!index(whenpause, key)) /* if no pause/print of this display */ return 0; npauses++; /* count this visit */ if (batchmode) { /* if batch, output snapshot */ mstatus(msg, C_Prompt); /* set prompt message */ devsnap(); /* write frame */ mstatus("", C_Background); /* clear the prompt */ if (npauses == pauselimit) /* if limit hit, quit now */ mquit(NormalExit); return 0; } if (ttyi == NULL || c1 == EOF) { /* if no tty, or EOF already seen */ c1 = EOF; /* fake EOF for return */ return EOF; } else { fprintf(ttyo, "memmon pause: %s: ", msg); /* issue prompt */ fflush(ttyo); mstatus(msg, C_Prompt); /* also post on screen*/ devflush(); c1 = 0; while ((c2 = getc(ttyi)) != '\n' && c2 != '\r') /* get char up to CR */ if (c2 == EOF || c2 == '\04') { /* handle eof */ c1 = EOF; break; } else c1 = c2; /* save previous char */ } if (c1 == 'q' || npauses == pauselimit) mquit(NormalExit); /* quit on 'q' or if limit hit */ mstatus("", C_Background); /* clear the prompt */ return c1; /* return char before CR */ }/* * mstatus(msg, color) - post status message, erasing previous one. */novalue mstatus(msg, color)char *msg;int color; { char buf[StatusLength]; int i; char *p; for (i = 0, p = buf; i < StatusLength-1; i++) if (*msg) *p++ = *msg++; else *p++ = ' '; *p++ = '\0'; mtext(buf, 0, 0, color, C_Background); }/* * mtext(string, row, col, fgcolr, bgcolr) - display text in colored box. * * Just checks that we haven't suppressed the text, then calls devtext(). */novalue mtext(s, row, col, fg, bg)char *s;int row, col, fg, bg; { if (textrow > 0) devtext(s, row, col, fg, bg); } :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:memmon Folder:mproto.h
/* * mproto.h: prototypes for functions used in memmon and drivers. *//* * The following just puts "struct region" in global scope for strict ANSI * compilers. We do it this way for fear that some compilers can't handle * the correct method, which would be an empty declaration "struct region;". */struct region *fictitious();/* * Actual prototypes. *//* mmain.c */novalue mquit Params((int exitcode));/* mcontrol.c */novalue skipgc Params((int n));novalue memmon Params((noargs)); /* mcolors.c */novalue initcolors Params((noargs));novalue readcolors Params((char *filename));novalue setmap Params((int m, int c));novalue legend Params((noargs));/* mutils.c */int chop Params((char *s, char *w[], int n, int c));char * trim Params((char *s, int c));novalue pstext Params((char *s));novalue pexit Params((char *file));novalue litout Params((noargs));/* minput.c */int getcmd Params((word *addr, word *len));word getshow Params((noargs));novalue getregion Params((struct region *region));novalue rsync Params((struct region *rgn, char *label));/* moutput.c */novalue refresh Params((noargs));novalue paintblk Params((struct region *r,word addr,word len,int color));novalue paintstr Params((word addr, word len, int c1, int c2));int gcwait Params((int key, char *msg));int mpause Params((int key, char *msg)); novalue mstatus Params((char *msg, int color));novalue mtext Params((char *s, int row, int col, int fg, int bg));/* common to all device drivers */novalue devsetup Params((noargs));novalue devinit Params((noargs));novalue devmap Params((noargs));novalue devflood Params((int c));novalue devpaint Params((word s, word n, int c, int b));novalue devtext Params((char *s, int row, int cog, int bg));novalue devsnap Params((noargs));novalue devflush Params((noargs));novalue devterm Params((noargs));/* batch mode driver functions */novalue batbegin Params((noargs));novalue battext Params((char *s, int row, int col, int fg, int bg));novalue batmem Params((unsigned char mbuf[]));novalue batterm Params((noargs)); :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:memmon Folder:msymbols.def
# Color symbols and labels, blocktype keys, and legend entries.# This file is preprocessed (see mksym.icn) to make C code.# Each entry has four whitespace-separated fields:# symbol Symbol name for referencing a color from C code.# code Input character representing a particular block type.# label Block or color label for use on the legend and in color specs.# comments arbitrary comments as desired.# Order is significant. Symbols are assigned beginning at zero.# Legend entries (those with a nonzero code) must appear first; they are# displayed from left to right. A legend entry with a code of '-' is not# actually displayed, but inserts space between the other entries.## A maximum of 85 entries (= 255/3) can be defined.# colors associated with memory blocks, and other legend entries C_Free 'F' "free" free spaceC_CoBlk 'X' "coexpr" co-expression blockC_Alien 'A' "alien" alienDummy1 '-' "-" (legend separator)C_String '"' "string" stringDummy2 '-' "-" (legend separator)C_Tvsubs 'u' "subs" substring trapped varC_File 'f' "file" file blockC_Refresh 'x' "refresh" refresh blockC_Bignum 'i' "int" long integerC_Real 'r' "real" real numberC_Record 'R' "record" record blockC_Set 'S' "set" set header blockC_Selem 's' "selem" set element blockC_List 'L' "list" list header blockC_Lelem 'l' "lelem" list element blockC_Table 'T' "table" table header blockC_Telem 't' "telem" table element blockC_Tvtbl 'e' "tvtbl" table elem trapped varC_Slots 'h' "hash" hash bucketsC_Cset 'c' "cset" cset# other colorsC_External 0 "ext" external blockC_Background 0 "background" background colorC_Bsep 0 "bsep" block separatorC_Ssep 0 "ssep" string separatorC_Marked 0 "marked" marked string or blockC_Unmarked 0 "unmarked" unmarked string or blockC_Status 0 "status" status textC_Prompt 0 "prompt" prompt textC_Title 0 "title" title textC_Rsizes 0 "regions" region sizesC_Black 0 "black" general purpose blackC_Grey 0 "grey" general purpose greyC_White 0 "white" general purpose whiteC_Blink 0 "blink" special entry for blinking :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:memmon Folder:msymbols.h
/* * mutils.c: utility functions used by memmon but not peculiar to it. */#include <ctype.h>#include "memmon.h"/* * chop(s, w, n, c) - break string into fields, a la awk(1). * * s is modified in place with '\0' replacing occurrences of separator char c. * If c is zero, any *string of* whitespace is a single separator. * * w is an array of n char pointers to receive addresses of the fields. * The return value gives the number of fields actually found; * additional entries in w are given the address of a null string. */int chop(s, w, n, c)char *s, *w[];int n, c; { int i; if (!c) /* skip leading whitespace in whitespace mode */ while (isspace(*s)) s++; for (i = 0; i < n && *s;) { /* while array not full and string not empty */ w[i++] = s; /* store field address */ if (c) while (*s && *s != c) /* skip to particular separator */ s++; else while (*s && !isspace(*s)) /* skip to whitespace */ s++; if (!*s) /* break at end of string */ break; *s++ = '\0'; /* terminate field and advance */ if (!c) while (isspace(*s)) /* skip multi spaces in c=0 mode */ s++; } while (i < n) /* fill rest of array with pointer to "" */ w[--n] = s; return i; /* return count of fields found */ }/* * trim(s, c) -- trim string at comments character c. * * The string s is trimmed in place by storing a null character after the last * "significant" character. A pointer to the first "significant" character is * returned. * * If c is nonzero, it indicates a comment character; the first appearance * of c that is not escaped by '\' indicates the start of the comments field. * Then (in any event) trailing whitespace is skipped. */char *trim(s, c)char *s;int c; { char *p; char *index(); while (isspace(*s)) /* skip initial whitespace */ s++; p = 0; if (c) for (p = s; p = index(p, c); p++) if (p == s || p[-1] != '\\') /* look for unescaped comment */ break; if (!p) p = s + strlen(s); /* or find end if none */ while (p > s && isspace(p[-1])) /* find last nonwhite */ --p; *p = '\0'; /* terminate after last nonwhite */ return s; /* and return pointer */ }/* * pstext(s) - write s as a PostScript string. */novalue pstext(s)char *s; { char c; putchar('('); while (c = *s++) { if (c == '\\' || c == '(' || c == ')') putchar('\\'); /* protect \\ \( \) */ putchar(c); /* output char */ } putchar(')'); }/* * pexit(file) - issue perror() message and abort. */novalue pexit(file)char *file; { fprintf(stderr, "%s: ", progname); perror(file); exit(ErrorExit); } /* * litout() - set literal output mode on stdout, iff it's a tty. * also set 9600 baud if current speed is unreasonable. * * Litout is only needed by binary output formats (mmrt/mmaed, not mmps or * mmmeta). THE CODE IS BSD SYSTEM DEPENDENT; a null routine is included * for other systems, and a manual stty command may be needed there. */#ifndef GenericBSDnovalue litout () /* not BSD -- will need to set tty modes manually */ { }#else /* GenericBSD *//* * The following kludge allows compilation under Vax 4.3BSD by an ANSI C * compiler such as gcc. It fixes a problem in <sgtty.c>. The fix is not * general, but it works for tty devices, and that is sufficient here. */#ifdef Standard#ifdef vax#define IOCPARM_MASK 0x7f#define IOC_VOID 0x20000000#define IOC_OUT 0x40000000#define IOC_IN 0x80000000#define _IO(t,y) (IOC_VOID|('t'<<8)|y)#define _IOR(t,y,z) (IOC_OUT|((sizeof(z)&IOCPARM_MASK)<<16)|('t'<<8)|y)#define _IOW(t,y,z) (IOC_IN|((sizeof(z)&IOCPARM_MASK)<<16)|('t'<<8)|y)#define _IOWR(t,y,z) (IOC_INOUT|((sizeof(z)&IOCPARM_MASK)<<16)|('t'<<8)|y)#endif /* vax */#endif /* Standard */#include <sgtty.h>novalue litout() { struct sgttyb ttyb; /* for setting tty attributes */ static int ldisc = NTTYDISC; static int lbits = LLITOUT; int fd; fd = fileno(stdout); if (!isatty(fd)) return; if (ioctl(fd, TIOCSETD, (char *) &ldisc)) pexit("can't select new tty driver"); if (ioctl(fd, TIOCGETP, (char *) &ttyb)) pexit("can't get sgtty block"); if (ioctl(fd, TIOCLBIS, (char *) &lbits)) pexit("can't set LLITOUT"); ttyb.sg_flags &= ~(RAW + ECHO); ttyb.sg_flags |= CRMOD; if (ttyb.sg_ospeed < B1200) /* if speed obviously bogus, */ ttyb.sg_ispeed = ttyb.sg_ospeed = B9600; /* try 9600 as a better guess */ if (ioctl(fd, TIOCSETN, (char *) &ttyb)) pexit("can't set tty attributes"); }#endif /* GenericBSD */ :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:memmon Folder:pastel.clr
# pastel color scheme, white backgroundfree 555 light greycoexpr 753 peachalien 222 greystring 631 reddish brownsubs 631 reddish brownfile 003 dark bluerefresh 400 dark redint 770 yellowreal 733 salmonrecord 753 peachset 657 light purpleselem 637 medium purplelist 246 medium bluelelem 267 pastel bluetable 574 light yellow-greentelem 262 light greentvtbl 141 dark greenhash 477 light bluecset 775 ivoryext 222 greybackground 777 whitebsep 777 whitessep 775 ivorymarked 666 light greyunmarked 777 whitestatus 000 blackprompt 400 dark redtitle 000 blackregions 000 blackblack 000grey 555white 777blink 777 white (blinks with black if possible) :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:memmon Folder:qms.clr
# Standard color definitions for memmon.## These definitions are optimized for the QMS ColorScript 100.# The best-looking colors have only one digit that is neither 0 nor 7.free 111 greycoexpr 420 brownalien 677 very light bluestring 775 ivorysubs 775 ivoryfile 670 light greenrefresh 420 brownint 753 peachreal 770 yellowrecord 607 magentaset 400 medium redselem 700 redlist 055 medium cyanlelem 077 cyantable 040 dark greentelem 070 greentvtbl 370 light greenhash 406 purplecset 760 yellow orangeext 677 very light bluebackground 000 blackbsep 000 blackssep 700 redmarked 111 dark greyunmarked 000 blackstatus 777 whiteprompt 770 yellowtitle 777 whiteregions 777 whiteblack 000grey 111white 777blink 777 white (blinks with black if possible) :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:memmon Folder:rt.clr
# Alternate memmon color scheme, designed for the Raster Tech One/80.free 222 greycoexpr 432 light brownalien 444 light greystring 775 ivorysubs 736 pinkfile 406 purplerefresh 004 navy blueint 753 peachreal 770 yellowrecord 740 orangeset 400 dark redselem 600 redlist 257 pastel bluelelem 135 medium bluetable 030 dark greentelem 050 medium greentvtbl 373 light greenhash 432 light browncset 530 reddish brownext 444 greybackground 000 blackbsep 000 blackssep 622 salmonmarked 111 dark greyunmarked 000 blackstatus 777 whiteprompt 770 yellowtitle 777 whiteregions 777 whiteblack 000grey 222white 777blink 777 white (blinks with black if possible) :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:ReadMe
Welcome to the MPW Icon Source Disk 4/8/90 ===========================================This is a small general information file for the Icon ProgrammingLanguage, Macintosh Programmer's Workshop version, source files disk.Most of the files are a compressed archive format. Each of the ".sit"archive files contain several compressed files. The files werecompressed using the archiving utility program StuffIt. Adecompress-only component of the Stuffit system, called UnStuffIt, isincluded on this disk.You will probably want to "unstuff" the documentation first, found inthe docs.sit archive. The documentation contains further information onextracting files and organizing the Icon hierarchy.To run UnStuffIt:1. Double click the UnStuffIt icon.2. From the "File" menu, choose "Open Archive…". Open the archive you wish to expand (e.g. docs.sit). UnStuffIt will open a window displaying the file names in the archive you opened.3. From the "Edit" menu, choose "Select All" to select all files for extraction (or click on individual files if you perfer to be selective).4. Click on the extract button near the bottom of the UnStuffIt window.5. UnStuffIt will present a "Save"-type dialog box so that you can specify the folder into which to place the extracted files, and even rename the file if you wish. Normal operation at this point is to simply navigate to the folder where you want the files and click the "Save All" button, causing all files to be stored in the specified folder without further intervention. :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:augment.dat
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:augment.icn
a(b,c)1(2(3,4),5)a(2,8(a,c(d,e))) :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:btrees.icn
## B I N A R Y T R E E S## This program accepts string representations of binary trees from# standard input. It performs a tree walk and lists the leaves of# each tree.record node(data,ltree,rtree)procedure main() local line, tree while line := read() do { tree := tform(line) write("tree walk") every write(walk(tree)) write("leaves") every write(leaves(tree)) }endprocedure tform(s) local value,left,right if /s then return s ? if value := tab(upto('(')) then { move(1) left := tab(bal(',')) move(1) right := tab(bal(')')) return node(value,tform(left),tform(right)) } else return node(s)endprocedure walk(t) suspend walk(\t.ltree | \t.rtree) return t.dataendprocedure leaves(t) if not(\t.ltree | \t.rtree) then return t.data suspend leaves(\t.ltree | \t.rtree)end :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:check.dat
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:check.icn
pdcocoexprtransmit :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:collate.dat
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:collate.icn
procedure main() s1 := collate(&cset,&cset) s2 := collate(reverse(&cset),reverse(&cset)) write(image(decollate(s1,0))) write(image(decollate(s1,1))) write(image(decollate(s2,1))) write(image(decollate(s2,0)))endprocedure collate(s1,s2) local length, ltemp, rtemp, t static llabels, rlabels, clabels, blabels, half initial { llabels := "abxy" rlabels := "cduv" blabels := llabels || rlabels clabels := "acbdxuyv" half := 4 ltemp := left(&cset,*&cset/2) rtemp := right(&cset,*&cset/2) clabels := collate(ltemp,rtemp) llabels := ltemp rlabels := rtemp blabels := string(&cset) half := *llabels } if *s1 > *s2 then { t := s1[*s2+1:0] s1 := s1[1:*s2+1] } else if *s2 > *s1 then { t := s2[*s1+1:0] s2 := s2[1:*s1+1] } else t := "" length := *s1 if length <= half then return map(left(clabels,2*length),left(llabels,length) || left(rlabels,length),s1 || s2) || t else return map(clabels,blabels,left(s1,half) || left(s2,half)) || collate(right(s1,length-half),right(s2,length-half)) || tendprocedure decollate(s,n) static dsize, image, object local ssize initial { image := collate(&cset[2:0],repl(&cset[1],*&cset-1)) object := string(&cset) dsize := *image } n %:= 2 ssize := *s if ssize + n <= dsize then return map(object[1+:(ssize+n)/2],image[(n+1)+:ssize],s) else return map(object[1+:(dsize-2)/2],image[(n+1)+:dsize-2], s[1+:(dsize-2)]) || decollate(s[dsize-1:0],n)end :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:concord.dat
Order, Coleoptera, (Beetles). Many beetles are colored so asto resemble the surfaces which they habitually frequent, and they thusescape detection by their enemies. Other species, for instance, diamond-beetles, are ornamentedwith splendid colors, which are often arranged in stripes, spots, crosses,and other elegant patterns. Such colors can hardly serve directly as a protection, except in the caseof certain flower-feeding species; but they may serve as a warning or means ofrecognition, on the same principle as thephosphorescence of the glow-worm.As with beetles the colors of the two sexes are generally alike, we haveno evidence that they have been gained through sexual selection; but this isat least possible, for they may have been developed in one sex and thentransferred to the other; and this view is even in some degree probablein those groups which possess other well-marked secondarysexual characters. Blind beetles, which cannot, of course, behold eachother's beauty, never, as I hear from Mr. Waterhouse, Jr., exhibit brightcolors, though they often have polished coats; but the explanation of theirobscurity may be that they generally inhabit caves and other obscure stations. :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:concord.icn
procedure main() local letters, line, wordlist, word, words, maxword, lineno, i local j, lines, numbers letters := &lcase ++ &ucase ++ '\'' words := table("") maxword := lineno := 0 while line := read() do { lineno +:= 1 write(right(lineno,6)," ",line) line := map(line) # fold to lowercase i := 1 while j := upto(letters,line,i) do { i := many(letters,line,j) word := line[j:i] if *word < 3 then next # skip short words maxword <:= *word # keep track of longest word # if it's a new word, start set if *words[word] = 0 then words[word] := set([lineno]) else insert(words[word],lineno) # else add the line number } } write() wordlist := sort(words) # sort by words i := 0 while word := wordlist[i +:= 1][1] do { lines := "" # build up line numbers numbers := sort(wordlist[i][2]) while lines ||:= get(numbers) || ", " write(left(word,maxword + 2),": ",lines[1:-2]) }end :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:diffwrds.dat
procedure main() local limit, s, i limit := 100 s := set([]) every insert(s,1 to limit) every member(s,i := 2 to limit) do every delete(s,i + i to limit by i) primes := sort(s) write("There are ",*primes," primes in the first ",limit," integers.") write("The primes are:") every write(right(!primes,*limit + 1))end :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:diffwrds.icn
## D I F F E R E N T W O R D S## This program lists all the different words in the input text.# The definition of a "word" is naive.procedure main() letter := &lcase ++ &ucase words := set() while text := read() do text ? while tab(upto(letter)) do insert(words,tab(many(letter))) every write(!sort(words))end :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:endetab.dat
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:endetab.icn
# test type conversion and error handling in entab/detabprocedure main () s := "rutabaga" if entab('1987') ~== "1789" then write ("oops 1") if detab('1492') ~== "1249" then write ("oops 2") if entab(" ","3") ~== "\t\t" then write ("oops 3") if detab("\t\t","3") ~== " " then write ("oops 4") ferr (103, entab, []) ferr (103, detab, []) ferr (103, entab, [[]]) ferr (103, detab, [[]]) ferr (101, entab, [s,2,3,&lcase]) ferr (101, detab, [s,4,5,&ucase]) ferr (210, entab, [s,7,4]) ferr (210, entab, [s,6,6]) ferr (210, detab, [s,8,5]) ferr (210, detab, [s,3,3]) end# ferr(err,func,arglst) -- call func(args), verify that error "err" is producedprocedure ferr (err, func, args) msg := "oops -- " || image(func) || "(" || image (val) || ") " &error := 1 if func!args then write (msg, "succeeded") else if &error ~= 0 then write (msg, "failed but no error") else if &errornumber ~= err then write (msg, "got error ",&errornumber," instead of ",err) &error := 0 return end :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:endetab1.dat
## test data for entab/detab tester; see driver program's comments for details## Remember that the characters --> "!.$" <-- are metacharacters, and cannot# be used randomly for punctuation; I got away with it that time by placing# them carefully <stop># first try with default parameters (9,17,25,33,etc)x x x x x x x x!.......x!....... x!....... x!....... x!....... x!....... x!....... x!....... x!.......!.......xx!......!.......x x!.....!.......x x!....!.......x x!...!.......x x!..!.......x x!.!.......x x!!.......x # tab replaces one char as part of longer run x!.......x!.......x!......x!....... x!.....x!....... x!....x!....... x!...x!....... x!..x!....... x!.x!....... x x # tab does not replace one-char run!....... xx!.......!.......xabcde!..xabcdef!.xabcdefg xabcdefg xabcdefg xabcdefg xabcdefg xabcdefg xabcdefg xabcdefg xabcdefg!!.......x# test some lines with trailing spaces$ $ $ $ $ $ $ $!.......$!....... $!....... $!....... $!....... $!....... $!....... $!....... $!.......!.......$!.......!....... $!.......!....... $!.......!.......!.......!.......!.......!.......!.......!....... wxyz!.......!.......!.......!.......!.......!.......!.......!.......!.......xyz!.......!.......!.......!.......!.......!.......!.......!.......!....... yz!.......!.......!.......!.......!.......!.......!.......!.......!....... z!.......ENTRY!..SUUO!.......ENTRY!..NUUO!.......CAI!....1,[BYTE (9)"s","u","u","o","/","n","u","u","o",0]SUUO:!..TRZA!...T1,1!...!.......; flag suuo callNUUO:!..TRO!....T1,1!...!.......; flag nuuo call!.......MOVE!...T0,1-OFF(P)!....; get UUO code!.......MOVEM!..T0,UUO!.!.......; save uuo!.......MOVE!...T0,2-OFF(P)!....; load register value!.......XCT!....UUO!....!.......; issue UUO!....... TRZE!..T1,1!...!.......; skip unless non-skip from nuuo call!....... TRZE!..T1,1!...!.......;less skip-return from nuuo call!....... HRREI!.T0,ERR!.!.......; indicate UUO failure!.......MOVE!...T1,T0!..!.......; return result in r1!.......POPJ!...P,!.....!.......; return# now try tabs every 4 columns= entab(s,5)xxx xx x x x x x x x x x x!...x!..x!...x!.. x!... x!. x!... x!. x!... x!!...x!... x!!... x!...!...!...!...!...!...!...!...!...!...!...!...!...!...!...!...!...!...!...xyzxxxxxxx xxxx xxxx xxxx xxxx!!...xxxx!!... xxxx$xxx $xxx $xxx $xxx $xxx!!...$xxx!!... $smatch(s1,s2)char *s1, *s2;{!...while (~((*s1 ^ *s2) & 0137))!...!...if (~*s1)!...!...!...return 0;!...!...else!...!...!...s1++, s2++;!...return ((*s1 & 0137) - (*s2 & 0137));}# try col 8, then every 4= entab(s,8,12)!......01!.student-record!......!...03!.name pic x(25)!......!...03!.home-address!......!...!...05!.city pic x(15)!......!...!...05!.state pic xx!......!...!...05!.big-zip!......!...!...!...07!.zip pic 9(5)!......!...!...!...07!.plus-4 pic 9(4)!......!...!...!...!...!...!...!...!...!...!...!...!...!...!...!...!...!...xyz# try irregular columns= entab(11,18,30,36)!.........entry!.sys= sys2!....xj sys3!....sa1!...a6!.........lx1!...59-40!.........mi x1,sys3!......wait until done if RCL bit set sys=!....subr!..=!..........entry / exit sys1!....sa1!...1!.........nz x1,sys1!......wait ra+1 clear!.........sa6!...1!..........store request!.........eq sys2!.........!.......!..........!.....!.....!.....!.....!.....!.....!..... xyz# and now for something completely different= entab(s,11,60) # (11,60,61) would need less scratch space on detab but few will know/use thisloop:!....line = input!....................................:f(end)!.........output = line!...................................:(loop)# end cases= entab(s,2)x x!!x!!!x!!!!x!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!xyz= entab(s,2,4)x x x!!.x!!. x!!.!.x!!.!.!.!.!.!.!.!.!.!.xyz!!.!.!.!.!.!.!.!.!.!.!.!.!.!.!.!.!.!.!.!.!.!.!.!.!.!.!.!.!.!.!.!.!.!.!.!.!.xyz= entab(s,3)x x!.x!. x!.!.x!.!.!.!.!.!.!.!.!.!.xyz!.!.!.!.!.!.!.!.!.!.!.!.!.!.!.!.!.!.!.!.!.!.!.!.!.!.!.!.!.!.!.!.!.!.!.!.!.xyz= entab(s,3,4)x x!.x!.!x!.!!x!.!!!x!.!!!!x!.!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!xyz# now go back to an interval of 4 and test special characters in input= entab(s,5)# first, just tabs in the input\t$\t $\t $\t $\t!...$ \t!...$ \t!...$ \t!...$!...\t!...$\tx\t x\t x\t x\t!...x \t!...x \t!...x \t!...x!...\t!...xabc\tdef\tghi\tjklsmatch(s1,s2)char *s1, *s2;{\twhile (~((*s1 ^ *s2) & 0137))\t\tif (~*s1)!...!...!...return 0; \t\telse!...!...!...s1++, s2++; \treturn ((*s1 & 0137) - (*s2 & 0137));}# now some backspacesabc\b!.de\b!..fghij\b!...k# use irregular stops for testing wierder situations= entab(5,7,10)!...!.!..!..!..!..!..!..!..!..!..!..!..!..!..!..!..!..!..!..!..!..!..!..!...!.!..\b\b\b\b\b\b\b\b\b!...!.!..!..!...!.!..\n!...!.!..\r!...!.!..\n\r!...!.!..\r\n!...!.!..!...\a!.\a!..\a!..!...\b\b\b\b!...\b\a\b\a!.!.!..\n\n\n \t!.!..\n :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:endetab1.icn
## Test driver for entab and detab## Input is read from standard input. Commentary and error reports go to# standard output.## Input lines are first preprocessed by interpreting escape sequences \a, \b,# \n, \r, and \t and trimming a trailing '$' character.# # Input lines beginning with "=" establish tab stop settings. Each numeric# field specifies a tab stop, according to the entab/detab specs.# # All other lines are passed through entab and then detab, and the results are# checked. The characters "!" and "." are replaced by spaces before calling# entab; "!" positions are expected to be replaced by tabs, with "." positions# disappearing. For example, "abcd!...ijk" tests that entab("abcd ijk")# returns "abcd\tijk".# # The result of each entab call is then passed to detab, with results expected# to match the original entab argument (or its detab, if it had any tabs).procedure main () params := setup ("=") # start with default tabs (no args) while line := escape (read ()) do { # read and preprocess line if line[1] == "=" then params := setup (line) # '=' line sets tab stops (arg list) else { s := map (line, "!.", " ") # turn "!." characters into spaces params[1] := s t := invoke (entab, params) # run entab if t ~== interp (line) then { # check results write ("entab failed for: ", map(line,"\t\r\n\b\007","!RNBA")) write (" returned value: ", map(t, "\t\r\n\b\007","!RNBA")) } else { if upto ('\t', s) then # detab input if it had a tab s := invoke (detab, params) params[1] := t t := invoke (detab, params) # detab the result of the entab if t ~== s then { # compare results write ("detab failed for: ", map(line,"\t\r\n\b\007","!RNBA")) write (" returned value: ", map(t, "\t\r\n\b\007","!RNBA")) } } } } endprocedure escape (line) # interpret escape sequences and trim one '$' if line[-1] == "$" then line := line[1:-1] s := "" line ? while not pos (0) do { s ||:= tab (upto ('\\') | 0) s ||:= (="\\" & case (c := move(1)) of { "a": "\007" "b": "\b" "n": "\n" "r": "\r" "t": "\t" default: "\\" || c }) } return s endprocedure interp (pattern) # interpret metacharacters '!.' s := "" pattern ? while not pos (0) do { tab (many ('.')) s ||:= tab (upto ('.') | 0) } return map (s, "!", "\t") endprocedure setup (line) # interpret and report a column spec line p := [&null] line ? while tab (upto (&digits)) do put (p, integer (tab (many (&digits)))) writes ("testing entab/detab(s") every writes (",", \!p) write (")") return p endprocedure invoke (func, a) # invoke a function with a list of up to 10 args return case *a of { 0: func () 1: func (a[1]) 2: func (a[1], a[2]) 3: func (a[1], a[2], a[3]) 4: func (a[1], a[2], a[3], a[4]) 5: func (a[1], a[2], a[3], a[4], a[5]) 6: func (a[1], a[2], a[3], a[4], a[5], a[6]) 7: func (a[1], a[2], a[3], a[4], a[5], a[6], a[7]) 8: func (a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8]) 9: func (a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8], a[9]) 10: func (a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8], a[9], a[10]) default: stop ("too many args for invoke") } end :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:errors.dat
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:errors.icn
hello world :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:gc.lst
gc1gc2mem01mem02 :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:gc1.dat
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:gc1.icn
procedure main() every 1 to 100 do { write(&collections) every 1 to 100 do list(1000) } write("collecting ...") collect() every s := repl("x",1 to 1000) do { cset(string(&lcase)) t := table() set([s]) s[2 : 5] }end :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:gc2.dat
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:gc2.icn
global defs, ifile, in, limit, tswitch, promptrecord nonterm(name)record charset(chars)record query(name)procedure main(x) local line, plist plist := [define,generate,grammar,source,comment,prompter,error] defs := table() defs["lb"] := [["<"]] defs["rb"] := [[">"]] defs["vb"] := [["|"]] defs["nl"] := [["\n"]] defs[""] := [[""]] defs["&lcase"] := [[charset(&lcase)]] defs["&ucase"] := [[charset(&ucase)]] defs["&digit"] := [[charset('0123456789')]] i := 0 while i < *x do { s := x[i +:= 1] | break case s of { "-t": tswitch := 1 "-l": limit := integer(x[i +:= 1]) | stop("usage: [-t] [-l n]") default: stop("usage: [-t] [-l n]") } } ifile := [&input] prompt := "" test := ["<a>::=1|2|3","<a>10","->","<b>::=<a>|<a><a>|<b><b>","<b>5", "<c>::=<b><b><b>","<c>100","<b>100"] every line := !test do { (!plist)(line) collect() every write(&collections) write("----------") }endprocedure comment(line) if line[1] == "#" then returnendprocedure define(line) return line ? defs[(="<",tab(find(">::=")))] := (move(4),alts(tab(0)))endprocedure defnon(sym) if sym ? { ="'" & chars := cset(tab(-1)) & ="'" } then return charset(chars) else if sym ? { ="?" & name := tab(0) } then return query(name) else return nonterm(sym)endprocedure error(line) write("*** erroneous line: ",line) returnendprocedure gener(goal) local pending, genstr, symbol repeat { pending := [nonterm(goal)] genstr := "" while symbol := get(pending) do { if \tswitch then write(&errout,genstr,symimage(symbol),listimage(pending)) case type(symbol) of { "string": genstr ||:= symbol "charset": genstr ||:= ?symbol.chars "query": { writes("*** supply string for ",symbol.name," ") genstr ||:= read() | { write(&errout,"*** no value for query to ",symbol.name) suspend genstr break next } } "nonterm": { pending := ?\defs[symbol.name] ||| pending | { write(&errout,"*** undefined nonterminal: <",symbol.name,">") suspend genstr break next } if *pending > \limit then { write(&errout,"*** excessive symbols remaining") suspend genstr break next } } } } suspend genstr }endprocedure generate(line) local goal, count if line ? { ="<" & goal := tab(upto('>')) \ 1 & move(1) & count := (pos(0) & 1) | integer(tab(0)) } then { every write(gener(goal)) \ count return } else failendprocedure getrhs(a) local rhs rhs := "" every rhs ||:= sform(!a) || "|" return rhs[1:-1]endprocedure grammar(line) local file, out if line ? { name := tab(find("->")) & move(2) & file := tab(0) & out := if *file = 0 then &output else { open(file,"w") | { write(&errout,"*** cannot open ",file) fail } } } then { (*name = 0) | (name[1] == "<" & name[-1] == ">") | fail pwrite(name,out) if *file ~= 0 then close(out) return } else failendprocedure listimage(a) local s, x s := "" every x := !a do s ||:= symimage(x) return sendprocedure alts(defn) local alist alist := [] defn ? while put(alist,syms(tab(many(~'|')))) do move(1) return alistendprocedure prompter(line) if line[1] == "=" then { prompt := line[2:0] return }endprocedure pwrite(name,ofile) local nt, a static builtin initial builtin := ["lb","rb","vb","nl","","&lcase","&ucase","&digit"] if *name = 0 then { a := sort(defs) every nt := !a do { if nt[1] == !builtin then next write(ofile,"<",nt[1],">::=",getrhs(nt[2])) } } else write(ofile,name,"::=",getrhs(\defs[name[2:-1]])) | write("*** undefined nonterminal: ",name)endprocedure sform(alt) local s, x s := "" every x := !alt do s ||:= case type(x) of { "string": x "nonterm": "<" || x.name || ">" "charset": "<'" || x.chars || "'>" } return sendprocedure source(line) return line ? (="@" & push(ifile,in) & { in := open(file := tab(0)) | { write(&errout,"*** cannot open ",file) fail } })endprocedure symimage(x) return case type(x) of { "string": x "nonterm": "<" || x.name || ">" "charset": "<'" || x.chars || "'>" }endprocedure syms(alt) local slist slist := [] alt ? while put(slist,tab(many(~'<')) | defnon(2(="<",tab(upto('>')),move(1)))) return slistend :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:hello.dat
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:hello.icn
procedure main() write(&version) write(&host) every write(&features)end :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:icon.lst
btreeskrossdiffwrdsmeanderprefixrecognromansievewordcnt :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:io.dat
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:io.icn
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:key.icn
procedure main() T := table() every T[1 to 20] := 1 every write(key(T))end :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:kross.dat
elephants:peanutsencroachment:roachesgaggle:geese :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:kross.icn
## W O R D I N T E R S E C T I O N S## This program procedure accepts string pairs from standard input, with# the strings separated by semicolons. It then diagrams all the# intersections of the two strings in a common character.procedure main() local line, j while line := read() do { write() j := upto(':',line) cross(line[1:j],line[j+1:0]) }endprocedure cross(s1,s2) local j, k every j := upto(s2,s1) do every k := upto(s1[j],s2) do xprint(s1,s2,j,k)endprocedure xprint(s1,s2,j,k) write() every write(right(s2[1 to k-1],j)) write(s1) every write(right(s2[k+1 to *s2],j))end :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:large.dat
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:large.icn
procedure main () if not(&features == "large integers") then stop("large integers not supported") big := 111111111111111111111 med1 := "2222222222" med2 := "3333333333" small := 4 every optest ("+" | "-" | "*" | "/" | "%" |"iand"|"ior"|"ixor"|"<"|"=", big | -big | small | -small, big | -big | small | -small) every optest ("+" | "-" | "*" | "/" | "%" |"iand"|"ior"|"ixor"|"<"|"=", big | med1 | -med1, med1 | med2 | -med2) every optest ("^", big | -big | small | -small, 2 | 5) every optest ("^", 2 | 3, 10 | 30 ) every optest ("ishift", big |-big | med1 | -med1 | small, 1 | 8 | -1 | -39)endprocedure optest (op, a, b) write (a, " ", op, " ", b, " = ", op(a,b)|"none")end :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:large.lst
overlarge :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:math.dat
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:math.icn
procedure main() every i := 1 to 25 do { v := 0.25 * i wf (v) if (v <= 1.0) then every wf ((acos | asin) (v)) else every wf ("" | "") every wf (atan(v) | atan(v,3)) every wf ((cos | sin | tan) (v)) every wf ((sqrt | exp | log) (v)) wf (log(v,3)) write () } endprocedure wf (v) writes(left(v,5)," ") end :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:meander.dat
abc:21234:2ABC:4 :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:meander.icn
## M E A N D E R I N G S T R I N G S## This main procedure accepts specifications for meandering strings# from standard input with the alphabet separated from the length by# a colon.procedure main() local line, alpha, n while line := read() do { line ? if { alpha := tab(upto(':')) & move(1) & n := integer(tab(0)) } then write(meander(alpha,n)) else stop("*** erroneous input ***") }endprocedure meander(alpha,n) local result, t, i, c, k i := k := *alpha t := n-1 result := repl(alpha[1],t) while c := alpha[i] do { if find(result[-t:0] || c,result) then i -:= 1 else {result ||:= c; i := k} } return resultend :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:mem01.dat
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:mem01.icn
procedure main() write(image(every repl(repl("xxx",50),write(1 to 100))) | "failed") write(image(repl(repl(repl(repl(&cset,100),100),100),100)) | "failed")end :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:mem02.dat
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:mem02.icn
[ constructed by hand ]ABCD EFGH IJKL MNOPAEIM BFJN CGKO DHLPAHKN BGLM CFIP DEJOAFLO BEKP CHJM DGINAGJP BHIO CELN DFKM :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:mffsol.icn
## mffsol.icn -- show solution graphically in mff format## input is assumed to be one line per round# each player is represented by a different ASCII character# matches are broken by whitespaceglobal range # vertical coordinate rangeglobal red, green, blue # current colorprocedure main (args) range := 1000 aset := cset(&ascii[34:128]) # set of usable ascii characters pset := '' # set of chars in use as players plist := "" # same, in order of appearance rounds := [] # list of rounds (one text line each) nmatches := 0 if *args > 0 then f := open(args[1]) | stop("can't open ",args[1]) else f := &input # read input and save in memory # (this first pass just accumulates a list of players) while line := read(f) do if line[1] ~== "[" & upto(aset,line) then { put(rounds,line) line ? while tab(upto(aset)) do { c := move(1) if not any(pset,c) then { # if first appearance of new player pset ++:= c # add to set of players plist ||:= c # add at end of list } } } # if all the characters are letters, arrange alphabetically if *(plist -- &ucase -- &lcase) = 0 then plist := string(cset(plist)) # calculate a position (angle) for each player, and draw the clock face write("1 metafile ", pct(125), " ", pct(100), " 0 0 0 init") angle := table() dtheta := 2 * 3.14159 / *pset theta := 3.14159 / 2 - dtheta / 2 every c := !plist do { angle[c] := theta cart(47, theta, -1, -1) write("(",c,") text") theta -:= dtheta } # draw each round in a different color n := 1 red := 250 green := 255 blue := 0 every r := !rounds do { write(red, " ", green, " ", blue, " color") x := pct(110) y := pct(100 - 4 * n) if y > 0 then write(x, " ", y, " (", n, ") text") r ? while tab(upto(aset)) do { match := tab(many(aset)) cart (45, angle[match[1]], 0, 0); writes ("begin ") cart (45, angle[match[2]], 0, 0); writes ("line ") cart (45, angle[match[3]], 0, 0); writes ("line ") cart (45, angle[match[4]], 0, 0); writes ("line ") cart (45, angle[match[1]], 0, 0); write ("line") cart (45, angle[match[3]], 0, 0); writes ("line stroke ") cart (45, angle[match[2]], 0, 0); writes ("begin ") cart (45, angle[match[4]], 0, 0); write ("line stroke") nmatches +:= 1 } n +:= 1 newcolor() } # write some final statistics write ("255 255 255 color") write ("0 0 (", *pset," players, ",*rounds," rounds, ",nmatches," matches) text") end# given polar coordinates (radius,angle,dx,dy), write cartesian equivalents # offset by (dx,dy)procedure cart (r,a,dx,dy) x := pct (50 + r * cos(a) + dy) y := pct (50 + r * sin(a) + dy) writes (x," ",y," ") end# return a string representing a given percentage of the coordinate rangeprocedure pct (n) return string(integer(n * range / 100)) end# set new color coordinates. iterate until acceptable.procedure newcolor() repeat { red := (red + 103) % 256 green := (green + 211) % 256 blue := (blue + 71) % 256 lum := 0.30 * red + 0.59 * green + 0.11 * blue if lum > 96 then return } end :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:mindfa.dat
abcdefgh01dabaacdbdadfgefggd :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:mindfa.icn
### mindfa -- minimize a DFArecord dfa(Q,S,d,q0,F) # a DFAprocedure main() x := getdfa() every 1 to 10 do showdfa("Reduced",minimize(showdfa("Original",x)))end## - getdfa() -- accept a dfa from input, return it##procedure getdfa()local Q,S,d,q0,Flocal q,a Q := readset("Enter states (1 character names): ") S := readset("Enter input alphabet: ") F := readset("Enter Final states (subset of states): ") writes("What is the start state? ") q0 := read() d := table() every q := !Q & a := !S do { writes("enter delta(",q,",",a,") = ") d[q||":"||a] := read() } return dfa(Q,S,d,q0,F)end## readset(s) - get a set#procedure readset(s)local t1 writes(s) t1 := [] every put(t1,!cset(read())) # the cset removes duplicates return t1end## showdfa(msg,D) -- show a dfa#procedure showdfa(msg,D)local q,a every 1 to 3 do write() write(msg," Deterministic Finite Automaton is:") write() write("\t(Q,S,delta,q0,F)") write() write("where:") write() writeset("Q",D.Q) writeset("S",D.S) writeset("F",D.F) write("\tStart state is ",D.q0) write("\tDelta: ") every q := !D.Q do { every writes("\td(",q,",",a := !D.S,") = ",D.d[q||":"||a]) write() } return Dend## writeset(msg,s) -- display a set#procedure writeset(msg,s)local tmp tmp := "" every tmp ||:= !s || "," write("\t",msg," = {",tmp[1:-1],"}") returnend## minimize(D) -- minimize a dfa#global distab, dlistsprocedure minimize(D)local F,QFlocal p,q,a,cs distab := table() dlists := table() F := D.F QF := diff(D.Q,D.F) every p := !F & q := !QF do distab[cset(p||q)] := "X" every ((p := !F & q := !F) | (p := !QF & q := !QF)) & p ~== q do if \distab[cset(D.d[p||":"||(a:=!D.S)]||D.d[q||":"||a])] then { distab[cset(p||q)] := "X" marklists(dlists[cset(p||q)]) } else every a := !D.S do if D.d[p||":"||a] ~== D.d[q||":"||a] then { cs := cset(D.d[p||":"||a]||D.d[q||":"||a]) if cs == cset(p||q) then next /dlists[cs] := [] put(dlists[cs],cset(p||q)) } return makemdfa(D,distab)end## marklists(l) -- recursively mark the pair of nodes# on list l.procedure marklists(l)local e if /l then return every e := !l do { distab[e] := "X" marklists(dlists[e]) } returnend## makemdfa(D,DT) -- Use the table from the minimization# to construct the minimal dfaprocedure makemdfa(D,DT)local elist, etab, qset, tlist, echecklocal p, q, Delta, q0 etab := table() # table of new states qset := '' every p := !D.Q do { qset ++:= p plike := equiv(p,etab) | cset(p) every q := !diff(D.Q,qset) & p ~== q do if /distab[cset(p||q)] then { plike ++:= equiv(q,etab) | q } etab[plike] := plike } tlist := [] elist := [] Delta := table() q0 := equiv(D.q0,etab) # start state of reduced machine put(tlist,q0) put(elist,q0) # only worry about states reachable # from [q0] echeck := table() # keep track of states echeck[q0] := q0 while q := get(tlist) do every a := !D.S do { Delta[q||":"||a] := equivdelta(q,a,D,etab) if /echeck[Delta[q||":"||a]] then { echeck[Delta[q||":"||a]] := Delta[q||":"||a] put(tlist,Delta[q||":"||a]) put(elist,Delta[q||":"||a]) } } return dfa(elist,D.S,Delta,q0,finalstates(D,elist))end## equiv(q,el) -- return the equivalence class in el containing q#procedure equiv(q,el) every p := !el do if p++q == p then return pend## equivdelta(p,a,D,el) -- apply delta to equiv. classes#procedure equivdelta(p,a,D,el)local q, r q := !p # any state in equiv. class p r := D.d[q||":"||a] # find state in original dfa return equiv(r,el) # return its equivalence classend## finalstates(D,el) -- build the set of final states#procedure finalstates(D,el)local flist, p, q ftab := table() every p := !D.F do ftab[q := equiv(p,el)] := q flist := [] every put(flist,(!sort(ftab))[1]) return flistend## diff(l1,l2) -- return the difference of two sets#procedure diff(l1,l2)local l,t1,t2 t1 := '' every t1 ++:= !l1 t2 := '' every t2 ++:= !l2 l := [] every put(l,!(t1--t2)) if *l = 0 then fail return lend :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:model.dat
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:model.icn
model :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:name.dat
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:name.icn
record complex(r,i)procedure main(a) static s every write(image(name(main | T | L | s | a))) T := table() L := list(200) L1 := [] every 1 to 200 do push(L1,1) write(image(L[10])) write(image(name(&error))) write(image(name(T["abc"]))) T["abc"] := 1 write(image(name(T["abc"]))) every write(image(name(L[1 | 2 | 3 | -1 | -10]))) every write(image(name(L1[1 | 2 | 3 | -1 | -10]))) write(image(name(complex().r)))end :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:new.lst
endetabendetab1version7version8namevarkey :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:numeric.dat
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:numeric.icn
protocollatetracerspellerpermutemindfaconcordrsg :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:over.dat
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:over.icn
procedure main() if not(&features == "large integers") then stop("large integers not supported") i := 100000 + 10000 write(i) i +:= 2 ^ 30 write(i) i +:= i write(i) i := 100000 * 10000 write(i) i +:= 2 ^ 30 write(i) i *:= i write(i) i := -100000 - 10000 write(i) i +:= -(2 ^ 30) write(i) i -:= 2 ^ 30 write(i)end :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:pdco.dat
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:pdco.icn
## D E F I N E D C O N T R O L O P E R A T I O N S## This program illustrates how programmer-control operations can be# implemented in Icon using co-expressions and the p{ ... }# syntax that facilitates their use.procedure main() if not(&features == "co-expressions") then stop("co-expressions not supported") write(Seqimage{1 to 10}) write(Seqimage{&fail}) write(Seqimage{(1 to 10 by 2) | (10 to 1 by -2)}) write(Seqimage{!"abc" || !"xy"}) write(Seqimage{Seqimage | main}) every write(Galt{1 to 10,!"abcd",1 to 10}) write(Seqimage{star("abc") \ 10}) write(Seqimage{1 to 1000,5}) write("---") every write(Limit{1 to 100,3}) write("---") every write(Ranseq{!"abcd",1 to 10}) every Parallel{|write,!"abcd",1 to 10} every Allpar{|write,!"abcd",1 to 10} \ 20 every Rotate{|write,!"abcd",1 to 10} \ 20endprocedure star(s) suspend "" | (star(s) || !s)endprocedure Galt(a) local e every e := !a do suspend |@eendprocedure Limit(a) local i, x while i := @a[2] do { a[1] := ^a[1] every 1 to i do if x := @a[1] then suspend x else break }endprocedure Ranseq(a) local x while x := @?a do suspend xendprocedure Seqimage(L) local s s := "" while s ||:= ", " || image(@L[1]) return "{" || s[3:0] || "}" | "{}"endprocedure Allpar(a) local i, x, done x := list(*a) done := list(*a,1) every i := 1 to *a do x[i] := @a[i] | fail repeat { suspend Call(x) every i := 1 to *a do if done[i] = 1 then ((x[i] := @a[i]) | (done[i] := 0)) if not(!done = 1) then fail }endprocedure Call(a) suspend case *a of { 1 : a[1]() 2 : a[1](a[2]) 3 : a[1](a[2],a[3]) 4 : a[1](a[2],a[3],a[4]) 5 : a[1](a[2],a[3],a[4],a[5]) 6 : a[1](a[2],a[3],a[4],a[5],a[6]) 7 : a[1](a[2],a[3],a[4],a[5],a[6],a[7]) 8 : a[1](a[2],a[3],a[4],a[5],a[6],a[7],a[8]) 9 : a[1](a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]) 10 : a[1](a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],a[10]) default : stop("Call : too many args.") }endprocedure Extract(a) local i, j, n, x x := list(*a/2) repeat { i := 1 while i < *a do { n := @a[i] | fail every 1 to n do x[(i + 1)/2] := @a[i + 1] | fail a[i + 1] := ^a[i + 1] i +:= 2 } suspend Call(x) }endprocedure Lifo(a) local i, x, ptr x := list(*a) ptr := 1 repeat { repeat if x[ptr] := @a[ptr] then { ptr +:= 1 (a[ptr] := ^a[ptr]) | break } else if (ptr -:= 1) = 0 then fail suspend Call(x) ptr := *a }endprocedure Parallel(a) local i, x x := list(*a) repeat { every i := 1 to *a do x[i] := @a[i] | fail suspend Call(x) }endprocedure Reverse(a) local i, x, ptr x := list(*a) ptr := *a repeat { repeat if x[ptr] := @a[ptr] then { ptr -:= 1 (a[ptr] := ^a[ptr]) | break } else if (ptr +:= 1) > *a then fail suspend Call(x) ptr := 1 }endprocedure Rotate(a) local i, x, done x := list(*a) done := list(*a,1) every i := 1 to *a do x[i] := @a[i] | fail repeat { suspend Call(x) every i := 1 to *a do if not(x[i] := @a[i]) then { done[i] := 0 if !done = 1 then { a[i] := ^a[i] x[i] := @a[i] | fail } else fail } }endprocedure Simple(a) local i, x x := list(*a) every i := 1 to *a do x[i] := @a[i] | fail return Call(x)end :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:permute.dat
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:permute.icn
procedure main() output := set() every 1 to 2 do every insert(output,permute("ogram")) every write(!output)endprocedure permute(s) local i, x, t if s == "" then return "" every i := 1 to *s do { x := s[i] t := s t[i] := "" suspend x || permute(t) }end :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:prefix.dat
x(((x)))x+1x-y-z3*delta+1((x+1))2^2^n(x^n)/(z+1) :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:prefix.icn
## I N F I X - T O - P R E F I X C O N V E R S I O N## This program accepts infix expressions from standard input and# writes the corresponding prefix expressions to standard output.procedure main() while write(prefix(read()))endprocedure prefix(s) s := strip(s) return lassoc(s,'+-' | '*/') | rassoc(s,'^') | sendprocedure strip(s) while s ? (="(" & s <- tab(bal(')')) & pos(-1)) return sendprocedoc(s,c) local j s ? every j := bal(c) return form(s,\j)endprocedure rassoc(s,c) local j return form(s,s ? bal(c))endprocedure form(s,k) local a1, a2, op s ? { a1 := tab(k) op := move(1) a2 := tab(0) } return op || "(" || prefix(a1) || "," || prefix(a2) || ")"end :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:proto.dat
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:proto.icn
# This program contains samples of all the basic syntactic# forms in Icon.record three(x,y,z)record zero()record one(z)global line, countprocedure main()endprocedure expr1(a, b) local x,y,z static e1 initial e1 := 0 () {} ();() [] [,] x.y x[i] x[i:j] x[i+:j] x[i-:j] (,,,) x(,,,) x!y not x |x !x *x +x -xendprocedure expr2(a, b[]) .x /x =x ?x \x ~x @x ^x x \ i x @ y i ^ j i * j i / j i % j c1 ** c2 i + j i - j c1 ++ c2 c1 -- c2 s1 || s2 a1 ||| a2 i < j i <= j i = j i >= j i > j i ~= j s1 << s2 s1 == s2 s1 >>= s2 s1 >> s2 s1 ~== s2 x === y x ~=== y x | y i to j i to j by k x := y x <- y x :=: y x <-> y i +:= j i -:= j i *:= jendprocedure expr3() i /:= j i %:= j i ^:= j i <:= j i <=:= j i =:= j i >=:= j i ~=:= j c1 ++:= c2 c1 --:= c2 c1 **:= c2 s1 ||:= s2 s1 <<:= s2 s1 <<=:= s2 s1 ==:= s2 s1 >>=:= s2 s1 >>:= s2 s1 ~==:= s2 s1 ?:= s2 a1 |||:= a2 x ===:= y x ~===:= y x &:= y x @:= y s ? x x & y create x return return x suspend x suspend x do y failendprocedure expr4() while e1 do break while e1 do break e2 while e1 do next case e of { x: fail (i > j) | 1 : return } case size(s) of { 1: 1 default: fail } if e1 then e2 if e1 then e2 else e3 repeat e while e1 while e1 do e2 until e1 until e1 do e2 every e1 every e1 do e2 x X_ &cset &null "abc" 'abc' "\n" "^a" "\001" "\x01" 1 999999 36ra1 3.5 2.5e4 4e-10end :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:recogn.dat
acacxcebaadcbabccsef :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:recogn.icn
## C F L R E C O G N I T I O N## This program takes strings from standard input and determines# whether or not they are sentences in the language defined by <s>.procedure main() local line while line := read() do if recogn(s,line) then write("accepted") else write("rejected")endprocedure recogn(goal,text) return text ? (goal() & pos(0))end# <s> ::= a <s> | <t> b | cprocedure s() suspend (="a" || s()) | (t() || ="b") | ="c"end# <t> ::= d <s> d | e | fprocedure t() suspend (="d" || s() || ="d") | ="e" | ="f"end :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:roman.dat
13460-43939994000 :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:roman.icn
## R O M A N N U M E R A L S## This program takes Arabic numerals from standard input and writes# the corresponding Roman numerals to standard outout.procedure main() local n while n := read() do write(roman(n) | "cannot convert")endprocedure roman(n) local arabic, result static equiv initial equiv := ["","I","II","III","IV","V","VI","VII","VIII","IX"] integer(n) > 0 | fail result := "" every arabic := !n do result := map(result,"IVXLCDM","XLCDM**") || equiv[arabic+1] if find("*",result) then fail else return resultend :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:rsg.dat
global defs, ifile, in, limit, prompt, tswitchrecord nonterm(name)record charset(chars)record query(name)procedure main(args) local line, plist, s, opts # procedures to try on input lines plist := [define,generate,grammar,source,comment,prompter,error] defs := table() # table of definitions defs["lb"] := [["<"]] # built-in definitions defs["rb"] := [[">"]] defs["vb"] := [["|"]] defs["nl"] := [["\n"]] defs[""] := [[""]] defs["&lcase"] := [[charset(&lcase)]] defs["&ucase"] := [[charset(&ucase)]] defs["&digit"] := [[charset(&digits)]] opts := getopt(args,"tl+l+")[1] limit := \opts["l"] | 1000 tswitch := \opts["t"] &random := \opts["s"] ifile := [&input] # stack of input files prompt := "" while in := pop(ifile) do { # process all files repeat { if *prompt ~= 0 then writes(prompt) line := read(in) | break while line[-1] == "\\" do line := line[1:-1] || read(in) | break (!plist)(line) } close(in) }end# process alternatives#procedure alts(defn) local alist alist := [] defn ? while put(alist,syms(tab(upto('|') | 0))) do move(1) | break return alistend# look for comment#procedure comment(line) if line[1] == "#" then returnend# look for definition#procedure define(line) return line ? defs[(="<",tab(find(">::=")))] := (move(4),alts(tab(0)))end# define nonterminal#procedure defnon(sym) local chars, name if sym ? { ="'" & chars := cset(tab(-1)) & ="'" } then return charset(chars) else if sym ? { ="?" & name := tab(0) } then return query(name) else return nonterm(sym)end# note erroneous input line#procedure error(line) write("*** erroneous line: ",line) returnend# generate sentences#procedure gener(goal) local pending, symbol pending := [nonterm(goal)] while symbol := get(pending) do { if \tswitch then write(&errout,symimage(symbol),listimage(pending)) case type(symbol) of { "string": writes(symbol) "charset": writes(?symbol.chars) "query": { writes(&errout,"*** supply string for ",symbol.name," ") writes(read()) | { write(&errout,"*** no value for query to ",symbol.name) break } } "nonterm": { pending := ?\defs[symbol.name] ||| pending | { write(&errout,"*** undefined nonterminal: <",symbol.name,">") break } if *pending > \limit then { write(&errout,"*** excessive symbols remaining") break } } } } write()end# look for generation specification#procedure generate(line) local goal, count if line ? { ="<" & goal := tab(upto('>')) \ 1 & move(1) & count := (pos(0) & 1) | integer(tab(0)) } then { every 1 to count do gener(goal) return } else failend# get right hand side of production#procedure getrhs(a) local rhs rhs := "" every rhs ||:= listimage(!a) || "|" return rhs[1:-1]end# look for request to write out grammar#procedure grammar(line) local file, out, name if line ? { name := tab(find("->")) & move(2) & file := tab(0) & out := if *file = 0 then &output else { open(file,"w") | { write(&errout,"*** cannot open ",file) fail } } } then { (*name = 0) | (name[1] == "<" & name[-1] == ">") | fail pwrite(name,out) if *file ~= 0 then close(out) return } else failend# produce image of list of grammar symbols#procedure listimage(a) local s, x s := "" every x := !a do s ||:= symimage(x) return send# look for new prompt symbol#procedure prompter(line) if line[1] == "=" then { prompt := line[2:0] return }end# write out grammar#procedure pwrite(name,ofile) local nt, a static builtin initial builtin := ["lb","rb","vb","nl","","&lcase","&ucase","&digit"] if *name = 0 then { a := sort(defs,3) while nt := get(a) do { if nt == !builtin then { get(a) next } write(ofile,"<",nt,">::=",getrhs(get(a))) } } else write(ofile,name,"::=",getrhs(\defs[name[2:-1]])) | write("*** undefined nonterminal: ",name)end# look for file with input#procedure source(line) local file return line ? (="@" & push(ifile,in) & { in := open(file := tab(0)) | { write(&errout,"*** cannot open ",file) fail } })end# produce string image of grammar symbol#procedure symimage(x) return case type(x) of { "string": x "nonterm": "<" || x.name || ">" "charset": "<'" || x.chars || "'>" }end# process the symbols in an alternative#procedure syms(alt) local slist static nonbrack initial nonbrack := ~'<' slist := [] alt ? while put(slist,tab(many(nonbrack)) | defnon(2(="<",tab(upto('>')),move(1)))) return slistend# stop, noting incorrect usage#procedure Usage() stop("usage: [-t] [-l n] [-s n]")endprocedure getopt(arg,optstring) local x,i,c,otab,flist,o,p /optstring := string(&lcase ++ &ucase) otab := table() flist := [] while x := get(arg) do x ? { if ="-" & not pos(0) then while c := move(1) do if i := find(c,optstring) + 1 then otab[c] := if any(':+.',o := optstring[i]) then { p := "" ~== tab(0) | get(arg) | stop("No parameter following ",x) case o of { ":": p "+": integer(p) | stop("-",c," needs numeric parameter") ".": real(p) | stop("-",c," needs numeric parameter") } } else 1 else stop("Unrecognized option: ",x) else put(flist,x) } return [otab,flist]end :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:scan.dat
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:scan.icn
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:sieve.icn
## S I E V E O F E R A T O S T H E N E S## This program illustrates the use of sets in implementing the# classical sieve algorithm for computing prime numbers.procedure main() local limit, s, i limit := 100 s := set() every insert(s,1 to limit) every member(s,i := 2 to limit) do every delete(s,i + i to limit by i) delete(s,1) primes := sort(s) write("There are ",*primes," primes in the first ",limit," integers.") write("The primes are:") every write(right(!primes,*limit + 1))end :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:speller.dat
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:speller.icn
procedure spell(n) local m n := integer(n) | stop(image(n)," is not an integer") if n <= 12 then return { "0zero,1one,2two,3three,4four,5five,6six,7seven,8eight,_ 9nine,10ten,11eleven,12twelve," ? { tab(find(n)) move(*n) tab(upto(",")) } } else if n <= 19 then return { spell(n[2] || "0") ? (if ="for" then "four" else tab(find("ty"))) || "teen" } else if n <= 99 then return { "2twen,3thir,4for,5fif,6six,7seven,8eigh,9nine," ? { tab(upto(n[1])) move(1) tab(upto(",")) || "ty" || if n[2] ~= 0 then "-" || spell(n[2]) } } else if n <= 999 then return { spell(n[1]) || " hundred" || (if (m := n[2:0]) ~= 0 then " and " || spell(m) else "") } else if n <= 999999 then return { spell(n[1:-3]) || " thousand" || (if (m := n[2:0]) ~= 0 then " and " || spell(m) else "") } else if n <= 999999999 then return { spell(n[1:-6]) || " million" || (if (m := n[2:0]) ~= 0 then " and " || spell(m) else "") } else failendprocedure spellw(n) write(n, " ", spell(n)) returnendprocedure main() every spellw(1 to 25) every spellw(30 to 110 by 3) spellw(945123342) every spellw(10000000 to 10000500 by 7)end :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:stand:augment.out
tree walkbcaleavesbctree walk34251leaves345tree walk2adec8aleaves2ade :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:stand:btrees.u1
proc main local 0,000020,line local 1,000020,tree local 2,000000,read local 3,000000,tform local 4,000000,write local 5,000000,walk local 6,000000,leaves con 0,010000,9,164,162,145,145,040,167,141,154,153 con 1,010000,6,154,145,141,166,145,163 declend filen btrees.icn line 11 mark L1lab L2 mark0 pnull var 0 var 2 pnull line 13 invoke 1 asgn unmark mark L2 mark L5 pnull var 1 var 3 var 0 line 14 invoke 1 asgn unmarklab L5 mark L6 var 4 str 0 line 15 invoke 1 unmarklab L6 mark L7 mark0 var 4 var 5 var 1 line 16 invoke 1 invoke 1 poplab L8 efaillab L9 unmarklab L7 mark L10 var 4 str 1 line 17 invoke 1 unmarklab L10 mark0 var 4 var 6 var 1 line 18 invoke 1 invoke 1 poplab L11 efaillab L12lab L3 unmark goto L2lab L4 unmarklab L1 pnull line 20 pfail endproc tform local 0,001000,s local 1,000020,value local 2,000020,left local 3,000020,right local 4,000000,tab local 5,000000,upto local 6,000000,move local 7,000000,bal local 8,000000,node local 9,000000,tform con 0,020000,1,050 con 1,002000,1,1 con 2,020000,1,054 con 3,020000,1,051 declend line 22 mark L1 mark0 pnull var 0 line 24 null unmark mark L2 pnull pretlab L2 pfail unmarklab L1 mark L3 var 0 line 25 bscan mark L4 pnull var 1 var 4 var 5 cset 0 invoke 1 invoke 1 asgn unmark mark L6 var 6 int 1 line 26 invoke 1 unmarklab L6 mark L7 pnull var 2 var 4 var 7 cset 2 line 27 invoke 1 invoke 1 asgn unmarklab L7 mark L8 var 6 int 1 line 28 invoke 1 unmarklab L8 mark L9 pnull var 3 var 4 var 7 cset 3 line 29 invoke 1 invoke 1 asgn unmarklab L9 mark L10 var 8 var 1 var 9 var 2 line 30 invoke 1 var 9 var 3 invoke 1 invoke 3 pretlab L10 pfail goto L5lab L4 mark L11 var 8 var 0 line 32 invoke 1 pretlab L11 pfaillab L5 line 25 escan unmarklab L3 pnull line 33 pfail endproc walk local 0,001000,t local 1,000000,walk declend line 35 mark L1 mark0 var 1 mark L4 pnull pnull var 0 line 36 field ltree nonnull esusp goto L5lab L4 pnull pnull var 0 field rtree nonnulllab L5 invoke 1 psusp poplab L2 efaillab L3 unmarklab L1 mark L6 mark L7 pnull var 0 line 37 field data pretlab L7 pfail unmarklab L6 pnull line 38 pfail endproc leaves local 0,001000,t local 1,000000,leaves declend line 40 mark L1 mark0 mark L2 mark L3 pnull pnull var 0 line 41 field ltree nonnull esusp goto L4lab L3 pnull pnull var 0 field rtree nonnulllab L4 unmark efaillab L2 pnull unmark mark L5 pnull var 0 field data pretlab L5 pfail unmarklab L1 mark L6 mark0 var 1 mark L9 pnull pnull var 0 line 42 field ltree nonnull esusp goto L10lab L9 pnull pnull var 0 field rtree nonnulllab L10 invoke 1 psusp poplab L7 efaillab L8 unmarklab L6 pnull line 43 pfail end :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:stand:btrees.u2
version U8.0.002record node,3 0,data 1,ltree 2,rtreeimpl localglobal 5 0,000011,node,3 1,000005,main,0 2,000005,tform,1 3,000005,walk,1 4,000005,leaves,1 :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:stand:btrees.ux
1 Order, Coleoptera, (Beetles). Many beetles are colored so as 2 to resemble the surfaces which they habitually frequent, and they thus 3 escape detection by their enemies. Other species, for instance, diamond-beetles, are ornamented 4 with splendid colors, which are often arranged in stripes, spots, crosses, 5 and other elegant patterns. Such colors can hardly serve directly as a protection, except in the case 6 of certain flower-feeding species; but they may serve as a warning or means of 7 recognition, on the same principle as the 8 phosphorescence of the glow-worm. 9 As with beetles the colors of the two sexes are generally alike, we have 10 no evidence that they have been gained through sexual selection; but this is 11 at least possible, for they may have been developed in one sex and then 12 transferred to the other; and this view is even in some degree probable 13 in those groups which possess other well-marked secondary 14 sexual characters. Blind beetles, which cannot, of course, behold each 15 other's beauty, never, as I hear from Mr. Waterhouse, Jr., exhibit bright 16 colors, though they often have polished coats; but the explanation of their 17 obscurity may be that they generally inhabit caves and other obscure stations.alike : 9and : 2, 5, 11, 12, 17are : 1, 3, 4, 9arranged : 4beauty : 15been : 10, 11beetles : 1, 3, 9, 14behold : 14blind : 14bright : 15but : 6, 10, 16can : 5cannot : 14case : 5caves : 17certain : 6characters : 14coats : 16coleoptera : 1colored : 1colors : 4, 5, 9, 16course : 14crosses : 4degree : 12detection : 3developed : 11diamond : 3directly : 5each : 14elegant : 5enemies : 3escape : 3even : 12evidence : 10except : 5exhibit : 15explanation : 16feeding : 6flower : 6for : 3, 11frequent : 2from : 15gained : 10generally : 9, 17glow : 8groups : 13habitually : 2hardly : 5have : 9, 10, 11, 16hear : 15inhabit : 17instance : 3least : 11many : 1marked : 13may : 6, 11, 17means : 6never : 15obscure : 17obscurity : 17often : 4, 16one : 11order : 1ornamented : 3other : 3, 5, 12, 13, 17other's : 15patterns : 5phosphorescence : 8polished : 16possess : 13possible : 11principle : 7probable : 12protection : 5recognition : 7resemble : 2same : 7secondary : 13selection : 10serve : 5, 6sex : 11sexes : 9sexual : 10, 14some : 12species : 3, 6splendid : 4spots : 4stations : 17stripes : 4such : 5surfaces : 2that : 10, 17the : 2, 5, 7, 8, 9, 12, 16their : 3, 16then : 11they : 2, 6, 10, 11, 16, 17this : 10, 12those : 13though : 16through : 10thus : 2transferred : 12two : 9view : 12warning : 6waterhouse : 15well : 13which : 2, 4, 13, 14with : 4, 9worm : 8 :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:stand:diffwrds.out
TheTherearebydeletedoendeveryfirstiininsertintegerslimitlocalmainmemberprimesprocedurerightssetsortthetowrite :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:stand:endetab.out
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:stand:endetab1.out
012243749627487991121241371491621741871992122242372492622742872993123243373493623743873994124244374494624744874995125245375495625745875996126246376496626746876997127247377497627747877998128248378498628748878999129249379499629749879991012102410371049106210741087109911121124113711491162117411871199121212241237collecting ... :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:stand:gc2.out
1000----------12122113132000----------<a>::=1|2|33000----------4000----------222323222213212323232213235000----------6000----------331131322113312321122323223133232312113232133311323232312312312312312233132213133313123121331333322222321121212133121323323132321311311232211213121123131331333123232321223233131123311233211211212221331232332333211231232332323221111311222122111112211123123221232112122223322333222211122111131132333233322222332111222312323333121232113332312332232331332221221233233323232231323323221131313333322323132212212233211332223331311221233231131123122133132121313222123123113311332333231321333311211313112312111111211131133121333222122222133322322122132123321131332312113212132321131112113123311311113121231132132133113321212312212313132123212223123333123221313321312123332321212112212211322122123211321212233321211221332111131213233231112331221211333313332112122212213131332323223231112232132311123223212311311122323211112313112122112311332232123233222212211111211313323112222113212233332321333211312111323133232123113332213323332131123313311004----------2133222122313231331332123111223331333322113333111332122331333131312122111323331333131311213211212121321232332113123212211133121233311211231222122113222133221312223112112133222231333231112123133212231221113131332233221313121322333311111133132113212333211212332112311231222332321233233212321321323333223233232331113313005---------- :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:stand:hello.u1
proc main local 0,000000,write declend filen hello.icn line 1 mark L1 var 0 line 2 keywd 35 invoke 1 unmarklab L1 mark L2 var 0 line 3 keywd 17 invoke 1 unmarklab L2 mark L3 mark0 var 0 line 4 keywd 15 invoke 1 poplab L4 efaillab L5 unmarklab L3 pnull line 5 pfail end :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:stand:hello.u2
version U8.0.002impl localglobal 1 0,000005,main,0 :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:stand:hello.ux
5131821071520412191761419311816 :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:stand:kross.out
pelephantsanuts pelephants a n u t selephants e a n u t s p eelephants n u t s p e aelephants u t s p e a n uelephants s p e a n u telephantsroachencroachments r o aencroachment h e sencroachment o a c h e s rencroachment a c h e s r oencroachment c h e s r o aencroachment h e s r o a cencroachment e s r o a c hencroachment sgaggleeesegaggle e e s egaggle e e s e ggaggle e s e g egaggle s e g e e sgaggle :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:stand:large.out
accbcabbaa14434241332312211AAACCCCBCCCACCBBCCBACCABCCAACBCBCACBBBCBBACBABCBAACACABBCABACAABCAAABBBBABBAABABAAAA :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:stand:mem01.out
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100failedRun-time error 205File mem01.icn; Line 3value out of rangeTrace back: main() repl("\x00\x01\x02\x03\x04\x05\x06\x07\b\t\n\v\f\r\x0e\x0f...",100) from line 3 in mem01.icn :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:stand:mem02.out
list_2(0)failedlist_2(1000)failedlist_2(2000) :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:stand:mffsol.out
1 metafile 1250 1000 0 0 0 init581 950 (A) text751 880 (B) text880 751 (C) text950 581 (D) text950 398 (E) text880 228 (F) text751 99 (G) text581 29 (H) text398 29 (I) text228 99 (J) text99 228 (K) text29 398 (L) text29 581 (M) text99 751 (N) text228 880 (O) text398 950 (P) text250 255 0 color1100 960 (1) text587 941 begin 750 874 line 874 750 line 941 587 line 587 941 line874 750 line stroke 750 874 begin 941 587 line stroke941 412 begin 874 249 line 750 125 line 587 58 line 941 412 line750 125 line stroke 874 249 begin 587 58 line stroke412 58 begin 249 125 line 125 249 line 58 412 line 412 58 line125 249 line stroke 249 125 begin 58 412 line stroke58 587 begin 125 750 line 249 874 line 412 941 line 58 587 line249 874 line stroke 125 750 begin 412 941 line stroke97 210 71 color1100 920 (2) text587 941 begin 941 412 line 412 58 line 58 587 line 587 941 line412 58 line stroke 941 412 begin 58 587 line stroke750 874 begin 874 249 line 249 125 line 125 750 line 750 874 line249 125 line stroke 874 249 begin 125 750 line stroke874 750 begin 750 125 line 125 249 line 249 874 line 874 750 line125 249 line stroke 750 125 begin 249 874 line stroke941 587 begin 587 58 line 58 412 line 412 941 line 941 587 line58 412 line stroke 587 58 begin 412 941 line stroke200 165 142 color1100 880 (3) text587 941 begin 587 58 line 125 249 line 125 750 line 587 941 line125 249 line stroke 587 58 begin 125 750 line stroke750 874 begin 750 125 line 58 412 line 58 587 line 750 874 line58 412 line stroke 750 125 begin 58 587 line stroke874 750 begin 874 249 line 412 58 line 412 941 line 874 750 line412 58 line stroke 874 249 begin 412 941 line stroke941 587 begin 941 412 line 249 125 line 249 874 line 941 587 line249 125 line stroke 941 412 begin 249 874 line stroke47 120 213 color1100 840 (4) text587 941 begin 874 249 line 58 412 line 249 874 line 587 941 line58 412 line stroke 874 249 begin 249 874 line stroke750 874 begin 941 412 line 125 249 line 412 941 line 750 874 line125 249 line stroke 941 412 begin 412 941 line stroke874 750 begin 587 58 line 249 125 line 58 587 line 874 750 line249 125 line stroke 587 58 begin 58 587 line stroke941 587 begin 750 125 line 412 58 line 125 750 line 941 587 line412 58 line stroke 750 125 begin 125 750 line stroke253 30 99 color1100 800 (5) text587 941 begin 750 125 line 249 125 line 412 941 line 587 941 line249 125 line stroke 750 125 begin 412 941 line stroke750 874 begin 587 58 line 412 58 line 249 874 line 750 874 line412 58 line stroke 587 58 begin 249 874 line stroke874 750 begin 941 412 line 58 412 line 125 750 line 874 750 line58 412 line stroke 941 412 begin 125 750 line stroke941 587 begin 874 249 line 125 249 line 58 587 line 941 587 line125 249 line stroke 874 249 begin 58 587 line stroke255 255 255 color0 0 (16 players, 5 rounds, 20 matches) text :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:stand:mindfa.out
Enter states (1 character names): Enter input alphabet: Enter Final states (subset of states): What is the start state? enter delta(a,0) = enter delta(a,1) = enter delta(b,0) = enter delta(b,1) = enter delta(c,0) = enter delta(c,1) = enter delta(d,0) = enter delta(d,1) = enter delta(e,0) = enter delta(e,1) = enter delta(f,0) = enter delta(f,1) = enter delta(g,0) = enter delta(g,1) = enter delta(h,0) = enter delta(h,1) = Original Deterministic Finite Automaton is: (Q,S,delta,q0,F)where: Q = {a,b,c,d,e,f,g,h} S = {0,1} F = {d} Start state is a Delta: d(a,0) = b d(a,1) = a d(b,0) = a d(b,1) = c d(c,0) = d d(c,1) = b d(d,0) = d d(d,1) = a d(e,0) = d d(e,1) = f d(f,0) = g d(f,1) = e d(g,0) = f d(g,1) = g d(h,0) = g d(h,1) = dReduced Deterministic Finite Automaton is: (Q,S,delta,q0,F)where: Q = {ag,bf,ce,d} S = {0,1} F = {d} Start state is ag Delta: d(ag,0) = bf d(ag,1) = ag d(bf,0) = ag d(bf,1) = ce d(ce,0) = d d(ce,1) = bf d(d,0) = d d(d,1) = agOriginal Deterministic Finite Automaton is: (Q,S,delta,q0,F)where: Q = {a,b,c,d,e,f,g,h} S = {0,1} F = {d} Start state is a Delta: d(a,0) = b d(a,1) = a d(b,0) = a d(b,1) = c d(c,0) = d d(c,1) = b d(d,0) = d d(d,1) = a d(e,0) = d d(e,1) = f d(f,0) = g d(f,1) = e d(g,0) = f d(g,1) = g d(h,0) = g d(h,1) = dReduced Deterministic Finite Automaton is: (Q,S,delta,q0,F)where: Q = {ag,bf,ce,d} S = {0,1} F = {d} Start state is ag Delta: d(ag,0) = bf d(ag,1) = ag d(bf,0) = ag d(bf,1) = ce d(ce,0) = d d(ce,1) = bf d(d,0) = d d(d,1) = agOriginal Deterministic Finite Automaton is: (Q,S,delta,q0,F)where: Q = {a,b,c,d,e,f,g,h} S = {0,1} F = {d} Start state is a Delta: d(a,0) = b d(a,1) = a d(b,0) = a d(b,1) = c d(c,0) = d d(c,1) = b d(d,0) = d d(d,1) = a d(e,0) = d d(e,1) = f d(f,0) = g d(f,1) = e d(g,0) = f d(g,1) = g d(h,0) = g d(h,1) = dReduced Deterministic Finite Automaton is: (Q,S,delta,q0,F)where: Q = {ag,bf,ce,d} S = {0,1} F = {d} Start state is ag Delta: d(ag,0) = bf d(ag,1) = ag d(bf,0) = ag d(bf,1) = ce d(ce,0) = d d(ce,1) = bf d(d,0) = d d(d,1) = agOriginal Deterministic Finite Automaton is: (Q,S,delta,q0,F)where: Q = {a,b,c,d,e,f,g,h} S = {0,1} F = {d} Start state is a Delta: d(a,0) = b d(a,1) = a d(b,0) = a d(b,1) = c d(c,0) = d d(c,1) = b d(d,0) = d d(d,1) = a d(e,0) = d d(e,1) = f d(f,0) = g d(f,1) = e d(g,0) = f d(g,1) = g d(h,0) = g d(h,1) = dReduced Deterministic Finite Automaton is: (Q,S,delta,q0,F)where: Q = {ag,bf,ce,d} S = {0,1} F = {d} Start state is ag Delta: d(ag,0) = bf d(ag,1) = ag d(bf,0) = ag d(bf,1) = ce d(ce,0) = d d(ce,1) = bf d(d,0) = d d(d,1) = agOriginal Deterministic Finite Automaton is: (Q,S,delta,q0,F)where: Q = {a,b,c,d,e,f,g,h} S = {0,1} F = {d} Start state is a Delta: d(a,0) = b d(a,1) = a d(b,0) = a d(b,1) = c d(c,0) = d d(c,1) = b d(d,0) = d d(d,1) = a d(e,0) = d d(e,1) = f d(f,0) = g d(f,1) = e d(g,0) = f d(g,1) = g d(h,0) = g d(h,1) = dReduced Deterministic Finite Automaton is: (Q,S,delta,q0,F)where: Q = {ag,bf,ce,d} S = {0,1} F = {d} Start state is ag Delta: d(ag,0) = bf d(ag,1) = ag d(bf,0) = ag d(bf,1) = ce d(ce,0) = d d(ce,1) = bf d(d,0) = d d(d,1) = agOriginal Deterministic Finite Automaton is: (Q,S,delta,q0,F)where: Q = {a,b,c,d,e,f,g,h} S = {0,1} F = {d} Start state is a Delta: d(a,0) = b d(a,1) = a d(b,0) = a d(b,1) = c d(c,0) = d d(c,1) = b d(d,0) = d d(d,1) = a d(e,0) = d d(e,1) = f d(f,0) = g d(f,1) = e d(g,0) = f d(g,1) = g d(h,0) = g d(h,1) = dReduced Deterministic Finite Automaton is: (Q,S,delta,q0,F)where: Q = {ag,bf,ce,d} S = {0,1} F = {d} Start state is ag Delta: d(ag,0) = bf d(ag,1) = ag d(bf,0) = ag d(bf,1) = ce d(ce,0) = d d(ce,1) = bf d(d,0) = d d(d,1) = agOriginal Deterministic Finite Automaton is: (Q,S,delta,q0,F)where: Q = {a,b,c,d,e,f,g,h} S = {0,1} F = {d} Start state is a Delta: d(a,0) = b d(a,1) = a d(b,0) = a d(b,1) = c d(c,0) = d d(c,1) = b d(d,0) = d d(d,1) = a d(e,0) = d d(e,1) = f d(f,0) = g d(f,1) = e d(g,0) = f d(g,1) = g d(h,0) = g d(h,1) = dReduced Deterministic Finite Automaton is: (Q,S,delta,q0,F)where: Q = {ag,bf,ce,d} S = {0,1} F = {d} Start state is ag Delta: d(ag,0) = bf d(ag,1) = ag d(bf,0) = ag d(bf,1) = ce d(ce,0) = d d(ce,1) = bf d(d,0) = d d(d,1) = agOriginal Deterministic Finite Automaton is: (Q,S,delta,q0,F)where: Q = {a,b,c,d,e,f,g,h} S = {0,1} F = {d} Start state is a Delta: d(a,0) = b d(a,1) = a d(b,0) = a d(b,1) = c d(c,0) = d d(c,1) = b d(d,0) = d d(d,1) = a d(e,0) = d d(e,1) = f d(f,0) = g d(f,1) = e d(g,0) = f d(g,1) = g d(h,0) = g d(h,1) = dReduced Deterministic Finite Automaton is: (Q,S,delta,q0,F)where: Q = {ag,bf,ce,d} S = {0,1} F = {d} Start state is ag Delta: d(ag,0) = bf d(ag,1) = ag d(bf,0) = ag d(bf,1) = ce d(ce,0) = d d(ce,1) = bf d(d,0) = d d(d,1) = agOriginal Deterministic Finite Automaton is: (Q,S,delta,q0,F)where: Q = {a,b,c,d,e,f,g,h} S = {0,1} F = {d} Start state is a Delta: d(a,0) = b d(a,1) = a d(b,0) = a d(b,1) = c d(c,0) = d d(c,1) = b d(d,0) = d d(d,1) = a d(e,0) = d d(e,1) = f d(f,0) = g d(f,1) = e d(g,0) = f d(g,1) = g d(h,0) = g d(h,1) = dReduced Deterministic Finite Automaton is: (Q,S,delta,q0,F)where: Q = {ag,bf,ce,d} S = {0,1} F = {d} Start state is ag Delta: d(ag,0) = bf d(ag,1) = ag d(bf,0) = ag d(bf,1) = ce d(ce,0) = d d(ce,1) = bf d(d,0) = d d(d,1) = agOriginal Deterministic Finite Automaton is: (Q,S,delta,q0,F)where: Q = {a,b,c,d,e,f,g,h} S = {0,1} F = {d} Start state is a Delta: d(a,0) = b d(a,1) = a d(b,0) = a d(b,1) = c d(c,0) = d d(c,1) = b d(d,0) = d d(d,1) = a d(e,0) = d d(e,1) = f d(f,0) = g d(f,1) = e d(g,0) = f d(g,1) = g d(h,0) = g d(h,1) = dReduced Deterministic Finite Automaton is: (Q,S,delta,q0,F)where: Q = {ag,bf,ce,d} S = {0,1} F = {d} Start state is ag Delta: d(ag,0) = bf d(ag,1) = ag d(bf,0) = ag d(bf,1) = ce d(ce,0) = d d(ce,1) = bf d(d,0) = d d(d,1) = ag :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:stand:model.out
table_1(0)failed6919491916201620table_2(0)failed1aiqy8hpx7gow6fnv5emu4dlt3cks2bjrzfailedset_1(2)set_2(0)set_3(10)3152107419638failedset_4(0)failed5131821071520412191761419311816failedfailed5132107412196143118failedfailedset_6(8)set_7(32)set_8(2)set_9(24)32aiqy2hpxabgowaa4fnv1emudlt3cksbjrzfailed2abfailediqyhpxgowfnvemudltcksjrzfailed :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:stand:name.out
"main""T""L""s""a"&null"&error""T[\"abc\"]""T[\"abc\"]""L[1]""L[2]""L[3]""L[200]""L[191]""L[1]""L[2]""L[3]""L[200]""L[191]""complex.r" :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:stand:numeric.out
argmoaromggramogromaoramgorgmaagomramogramrogaormggmroagormaogamromagrrgamorgomarmagormogaaogrmaomrgarmgoarogmgoarmgomramoargmogramragomrogaoragmormgaagromaorgmgaomrgmoarmgroamorgaoagmromgarragmoraomgrmgaormoaggrmaogroammrgaomroagorgamormaggaromgorammaogrmarogmgoarmoragoamgrogmarramgoraogmrgmaorgoamamgroamorggmarogmoraomargomgraagrmoamgoramrgoaogmrgmaorgoamrogrmaomrgarmaogrmgoaroamgrogmaagmroagormargomarmoggraomgrmoamgaromgoramraogmrgoaogarmogmraagmoraomgrgarmogmraomgaormoagroarmgomragrgaomrgmoaroagmromgagamrogaormmagromaorgoagrmoamrggamorgomarmagormargomgraomogaroargmogramragomramogrogamromag :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:stand:prefix.out
xx+(x,1)-(-(x,y),z)+(*(3,delta),1)+(x,1)^(2,^(2,n))/(^(x,n),+(z,1)) :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:stand:proto.out
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:stand:proto.u1
proc main declend filen proto.icn line 10 line 11 pfail endproc expr1 local 0,001000,a local 1,001000,b local 2,000020,x local 3,000020,y local 4,000020,z local 5,000040,e1 local 6,000000,i local 7,000000,j con 0,002000,1,0 declend line 12 init L1 mark L1 pnull var 5 int 0 line 15 asgn unmarklab L1 mark L2 pnull unmarklab L2 mark L3 pnull unmarklab L3 mark L4 pnull unmarklab L4 mark L5 pnull unmarklab L5 mark L6 pnull line 19 llist 0 unmarklab L6 mark L7 pnull pnull pnull line 20 llist 2 unmarklab L7 mark L8 pnull var 2 line 21 field y unmarklab L8 mark L9 pnull var 2 var 6 line 22 subsc unmarklab L9 mark L10 pnull var 2 var 6 var 7 line 23 sect unmarklab L10 mark L11 pnull var 2 var 6 dup var 7 line 24 plus sect unmarklab L11 mark L12 pnull var 2 var 6 dup var 7 line 25 minus sect unmarklab L12 mark L13 pushn1 pnull pnull pnull pnull line 26 invoke 4 unmarklab L13 mark L14 var 2 pnull pnull pnull pnull line 27 invoke 4 unmarklab L14 mark L15 var 2 var 3 invoke -1 unmarklab L15 mark L16 mark L17 var 2 unmark efaillab L17 pnull unmarklab L16 mark L18lab L19 mark0 var 2 chfail L19 esusp unmarklab L18 mark L20 pnull var 2 line 31 bang unmarklab L20 mark L21 pnull var 2 line 32 size unmarklab L21 mark L22 pnull var 2 line 33 number unmarklab L22 mark L23 pnull var 2 line 34 neg unmarklab L23 pnull line 35 pfail endproc expr2 local 0,001000,a local 1,001000,b local 2,000000,x local 3,000000,i local 4,000000,y local 5,000000,j local 6,000000,c1 local 7,000000,c2 local 8,000000,s1 local 9,000000,s2 local 10,000000,a1 local 11,000000,a2 local 12,000000,k declend line 37 mark L1 pnull var 2 line 38 value unmarklab L1 mark L2 pnull var 2 line 39 null unmarklab L2 mark L3 pnull var 2 line 40 tabmat unmarklab L3 mark L4 pnull var 2 line 41 random unmarklab L4 mark L5 pnull var 2 line 42 nonnull unmarklab L5 mark L6 pnull var 2 line 43 compl unmarklab L6 mark L7 pnull var 2 line 44 coact unmarklab L7 mark L8 pnull var 2 line 45 refresh unmarklab L8 mark L9 var 3 line 46 limit var 2 lsusp unmarklab L9 mark L10 var 2 var 4 line 47 coact unmarklab L10 mark L11 pnull var 3 var 5 line 48 power unmarklab L11 mark L12 pnull var 3 var 5 line 49 mult unmarklab L12 mark L13 pnull var 3 var 5 line 50 div unmarklab L13 mark L14 pnull var 3 var 5 line 51 mod unmarklab L14 mark L15 pnull var 6 var 7 line 52 inter unmarklab L15 mark L16 pnull var 3 var 5 line 53 plus unmarklab L16 mark L17 pnull var 3 var 5 line 54 minus unmarklab L17 mark L18 pnull var 6 var 7 line 55 unions unmarklab L18 mark L19 pnull var 6 var 7 line 56 diff unmarklab L19 mark L20 pnull var 8 var 9 line 57 cat unmarklab L20 mark L21 pnull var 10 var 11 line 58 lconcat unmarklab L21 mark L22 pnull var 3 var 5 line 59 numlt unmarklab L22 mark L23 pnull var 3 var 5 line 60 numle unmarklab L23 mark L24 pnull var 3 var 5 line 61 numeq unmarklab L24 mark L25 pnull var 3 var 5 line 62 numge unmarklab L25 mark L26 pnull var 3 var 5 line 63 numgt unmarklab L26 mark L27 pnull var 3 var 5 line 64 numne unmarklab L27 mark L28 pnull var 8 var 9 line 65 lexlt unmarklab L28 mark L29 pnull var 8 var 9 line 66 lexeq unmarklab L29 mark L30 pnull var 8 var 9 line 67 lexge unmarklab L30 mark L31 pnull var 8 var 9 line 68 lexgt unmarklab L31 mark L32 pnull var 8 var 9 line 69 lexne unmarklab L32 mark L33 pnull var 2 var 4 line 70 eqv unmarklab L33 mark L34 pnull var 2 var 4 line 71 neqv unmarklab L34 mark L35 mark L36 var 2 esusp goto L37lab L36 var 4lab L37 unmarklab L35 mark L38 pnull var 3 var 5 push1 line 73 toby unmarklab L38 mark L39 pnull var 3 var 5 var 12 line 74 toby unmarklab L39 mark L40 pnull var 2 var 4 line 75 asgn unmarklab L40 mark L41 pnull var 2 var 4 line 76 rasgn unmarklab L41 mark L42 pnull var 2 var 4 line 77 swap unmarklab L42 mark L43 pnull var 2 var 4 line 78 rswap unmarklab L43 mark L44 pnull var 3 dup var 5 line 79 plus asgn unmarklab L44 mark L45 pnull var 3 dup var 5 line 80 minus asgn unmarklab L45 mark L46 pnull var 3 dup var 5 line 81 mult asgn unmarklab L46 pnull line 82 pfail endproc expr3 local 0,000000,i local 1,000000,j local 2,000000,c1 local 3,000000,c2 local 4,000000,s1 local 5,000000,s2 local 6,000000,a1 local 7,000000,a2 local 8,000000,x local 9,000000,y local 10,000000,s declend line 84 mark L1 pnull var 0 dup var 1 line 85 div asgn unmarklab L1 mark L2 pnull var 0 dup var 1 line 86 mod asgn unmarklab L2 mark L3 pnull var 0 dup var 1 line 87 power asgn unmarklab L3 mark L4 pnull var 0 dup var 1 line 88 numlt asgn unmarklab L4 mark L5 pnull var 0 dup var 1 line 89 numle asgn unmarklab L5 mark L6 pnull var 0 dup var 1 line 90 numeq asgn unmarklab L6 mark L7 pnull var 0 dup var 1 line 91 numge asgn unmarklab L7 mark L8 pnull var 0 dup var 1 line 92 numne asgn unmarklab L8 mark L9 pnull var 2 dup var 3 line 93 unions asgn unmarklab L9 mark L10 pnull var 2 dup var 3 line 94 diff asgn unmarklab L10 mark L11 pnull var 2 dup var 3 line 95 inter asgn unmarklab L11 mark L12 pnull var 4 dup var 5 line 96 cat asgn unmarklab L12 mark L13 pnull var 4 dup var 5 line 97 lexlt asgn unmarklab L13 mark L14 pnull var 4 dup var 5 line 98 lexle asgn unmarklab L14 mark L15 pnull var 4 dup var 5 line 99 lexeq asgn unmarklab L15 mark L16 pnull var 4 dup var 5 line 100 lexge asgn unmarklab L16 mark L17 pnull var 4 dup var 5 line 101 lexgt asgn unmarklab L17 mark L18 pnull var 4 dup var 5 line 102 lexne asgn unmarklab L18 mark L19 pnull var 4 sdup line 103 bscan var 5 escan asgn unmarklab L19 mark L20 pnull var 6 dup var 7 line 104 lconcat asgn unmarklab L20 mark L21 pnull var 8 dup var 9 line 105 eqv asgn unmarklab L21 mark L22 pnull var 8 dup var 9 line 106 neqv asgn unmarklab L22 mark L23 pnull var 8 var 9 line 107 asgn unmarklab L23 mark L24 pnull var 8 sdup var 9 line 108 coact asgn unmarklab L24 mark L25 var 10 line 109 bscan var 8 escan unmarklab L25 mark L26 var 8 pop var 9 unmarklab L26 mark L27 goto L30lab L28 pop mark L29 var 8 line 111 coret efaillab L29 cofail goto L29lab L30 create L28 unmarklab L27 mark L31 mark L32 pnull line 112 pretlab L32 pfail unmarklab L31 mark L33 mark L34 var 8 line 113 pretlab L34 pfail unmarklab L33 mark L35 mark0 var 8 line 114 psusp poplab L36 efaillab L37 unmarklab L35 mark L38 mark0 var 8 line 115 psusp pop mark0 var 9 unmarklab L39 efaillab L40 unmarklab L38 mark L41 line 116 pfail unmarklab L41 pnull line 117 pfail endproc expr4 local 0,000000,e1 local 1,000000,e2 local 2,000000,e local 3,000000,x local 4,000000,i local 5,000000,j local 6,000000,size local 7,000000,s local 8,000000,e3 local 9,000000,X_ con 0,002000,1,1 con 1,010000,3,141,142,143 con 2,020000,3,141,142,143 con 3,010000,1,012 con 4,010000,2,136,141 con 5,010000,1,001 con 6,002000,6,999999 con 7,002000,5,36ra1 con 8,004000,3.5 con 9,004000,2.5e4 con 10,004000,4e-10 declend line 119 mark L1lab L2 mark0 var 0 unmark mark L2 unmark pnull goto L4lab L3 unmark goto L2lab L4 unmarklab L1 mark L5lab L6 mark0 var 0 unmark mark L6 unmark var 1 goto L8lab L7 unmark goto L6lab L8 unmarklab L5 mark L9lab L10 mark0 var 0 unmark mark L10 goto L11lab L11 unmark goto L10lab L12 unmarklab L9 mark L13 mark0 var 2 eret mark L15 ccase var 3 line 124 eqv unmark pop pfail goto L14lab L15 mark L16 ccase mark L17 pnull var 4 var 5 line 125 numgt esusp goto L18lab L17 int 0lab L18 eqv unmark pop mark L19 pnull pretlab L19 pfail goto L14lab L16 efaillab L14 unmarklab L13 mark L20 mark0 var 6 var 7 line 127 invoke 1 eret mark L22 ccase int 0 line 128 eqv unmark pop int 0 goto L21lab L22 pop line 129 pfaillab L21 unmarklab L20 mark L23 mark0 var 0 unmark var 1 unmarklab L23 mark L24 mark L25 var 0 unmark var 1 goto L26lab L25 var 8lab L26 unmarklab L24 mark L27lab L28 mark L28 var 2lab L29 unmark goto L28lab L30 unmarklab L27 mark L31lab L32 mark0 var 0lab L33 unmark goto L32lab L34 unmarklab L31 mark L35lab L36 mark0 var 0 unmark mark L36 var 1lab L37 unmark goto L36lab L38 unmarklab L35 mark L39lab L40 mark L41 var 0 unmark efaillab L41 mark L40 pnulllab L42 unmark goto L40lab L43 unmarklab L39 mark L44lab L45 mark L46 var 0 unmark efaillab L46 mark L45 var 1lab L47 unmark goto L45lab L48 unmarklab L44 mark L49 mark0 var 0 poplab L50 efaillab L51 unmarklab L49 mark L52 mark0 var 0 pop mark0 var 1 unmarklab L53 efaillab L54 unmarklab L52 mark L55 var 3 unmarklab L55 mark L56 var 9 unmarklab L56 mark L57 line 142 keywd 4 unmarklab L57 mark L58 line 143 keywd 24 unmarklab L58 mark L59 str 1 unmarklab L59 mark L60 cset 2 unmarklab L60 mark L61 str 3 unmarklab L61 mark L62 str 4 unmarklab L62 mark L63 str 5 unmarklab L63 mark L64 str 5 unmarklab L64 mark L65 int 0 unmarklab L65 mark L66 int 6 unmarklab L66 mark L67 int 7 unmarklab L67 mark L68 real 8 unmarklab L68 mark L69 real 9 unmarklab L69 mark L70 real 10 unmarklab L70 pnull line 156 pfail end :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:stand:proto.u2
as the shadowy figure stares at a lake;he alights, and turns away.momentarily she kneels.while the boy casts toward a moon;the shadowy figure turns away, and pauses.as he kneels.as the boy damns a moon;the boy kneels, while waiting darkly.momentarily the shadowy figure lingers.frozen, the boy stares at the abyss;he kneels, and alights.as the shadowy figure alights.momentarily the shadowy figure captures a sky;a child pauses, but pauses.as the shadowy figure hesitates.momentarily she damns the darkness;a child turns away, but returns.momentarily he alights.as she captures a star;the shadowy figure reflects, while breathing silently.while the boy hesitates.as she damns the abyss;she pauses, and returns.frozen, the shadowy figure kneels.as a child captures a darkness;she reflects, and hesitates.frozen, she hesitates.as the shadowy figure damns a star;the boy kneels, but kneels.as the shadowy figure stares.as he damns the abyss;a child alights, while waiting silently.while he returns.as a child outlines the void;the boy reflects, but kneels.frozen, a child turns away.frozen, he captures the lake;he hesitates, but alights.frozen, he turns away.as he damns a lake;he pauses, while waiting darkly.as the boy reflects.frozen, she casts toward the lake;he returns, and kneels.while the boy alights.frozen, the shadowy figure stares at the cloud;the boy kneels, while pointing expectantly.frozen, the boy kneels.momentarily he outlines the darkness;he pauses, while pointing darkly.as the shadowy figure reflects.momentarily a child captures a cloud;he hesitates, while breathing silently.while she pauses.frozen, the shadowy figure casts toward a cloud;he stares, and kneels.frozen, a child returns.momentarily the boy captures the cloud;the shadowy figure returns, and stares.momentarily he turns away.momentarily the boy casts toward a moon;the boy lingers, and reflects.as the boy returns.as the boy outlines a abyss;the boy kneels, and kneels.momentarily the boy reflects.frozen, the boy casts toward the moon;he pauses, and turns away.while the shadowy figure hesitates.while a child damns the darkness;he returns, while breathing fearfully.momentarily the shadowy figure kneels.frozen, he damns the lake;he alights, and turns away.frozen, she reflects.as the shadowy figure damns the lake;the shadowy figure turns away, while breathing with fear.as she lingers.as he captures the abyss;the boy alights, but lingers.while she reflects.momentarily he outlines a sky;the shadowy figure turns away, but lingers.while she lingers.while the shadowy figure casts toward the cloud;the boy lingers, and turns away.while the shadowy figure hesitates.as she outlines the star;he turns away, and turns away.frozen, a child turns away.frozen, the shadowy figure outlines a abyss;she alights, and hesitates.while he reflects.while the shadowy figure captures a abyss;he hesitates, and kneels.while he kneels.momentarily the shadowy figure damns a darkness;she returns, and kneels.frozen, she hesitates.momentarily the shadowy figure stares at a cloud;the shadowy figure lingers, and reflects.while she pauses.momentarily he stares at a darkness;the shadowy figure hesitates, while waiting fearfully.momentarily she kneels.while she stares at the cloud;he pauses, but turns away.while he kneels.as she stares at the star;she pauses, but kneels.momentarily she turns away.while he damns a moon;she lingers, and pauses.frozen, he lingers.as the boy casts toward a lake;the boy kneels, and turns away.frozen, the boy turns away.momentarily he damns the lake;the shadowy figure alights, but returns.momentarily he returns.frozen, a child captures the cloud;the shadowy figure kneels, and hesitates.while a child reflects.frozen, a child damns the moon;she alights, while breathing darkly.momentarily a child lingers.momentarily the boy damns a cloud;she kneels, and turns away.as the boy lingers.momentarily the shadowy figure stares at a lake;a child stares, and hesitates.while he returns.momentarily he stares at a star;a child pauses, while waiting expectantly.as he kneels.frozen, the boy captures the lake;the boy alights, but turns away.frozen, the boy lingers.while the boy stares at the darkness;she hesitates, while waiting with fear.while she pauses.while a child outlines a sky;a child hesitates, and reflects.as a child reflects.momentarily the shadowy figure damns the abyss;she hesitates, but alights.while the boy reflects.as the boy damns the star;a child alights, while breathing fearfully.while the boy pauses.while the boy captures the lake;a child turns away, but lingers.frozen, she hesitates.momentarily the shadowy figure damns the cloud;the boy kneels, while pointing silently.while she stares.frozen, the boy captures a sky;the boy pauses, and turns away.frozen, the boy stares.frozen, she casts toward a moon;he returns, but hesitates.while a child stares.while he outlines the moon;he turns away, and pauses.frozen, a child hesitates.momentarily the shadowy figure captures a darkness;the boy alights, and returns.as she kneels.as the shadowy figure casts toward a abyss;a child pauses, and turns away.as the shadowy figure pauses.while he captures the cloud;the shadowy figure pauses, and pauses.while he kneels.as the shadowy figure damns the star;the boy lingers, but hesitates.frozen, the shadowy figure pauses.while a child casts toward the star;a child reflects, and returns.momentarily the boy pauses.frozen, she casts toward the void;the boy kneels, and reflects.while she turns away.momentarily the shadowy figure damns a cloud;she lingers, while pointing expectantly.while a child returns.frozen, she outlines a abyss;he hesitates, but kneels.as she reflects.momentarily she damns a void;the shadowy figure kneels, while waiting slowly.as he lingers.momentarily the boy casts toward the lake;a child reflects, and kneels.while a child hesitates.momentarily he damns a sky;she lingers, while breathing with fear.as she kneels.as she casts toward a cloud;she hesitates, and kneels.frozen, the shadowy figure lingers.as a child captures the star;the boy reflects, while pointing darkly.while a child returns.while a child stares at the sky;a child kneels, while waiting slowly.momentarily he returns.momentarily a child damns the sky;the shadowy figure hesitates, while pointing silently.momentarily the boy pauses.momentarily she casts toward the darkness;she stares, while waiting darkly.momentarily the boy turns away.frozen, the shadowy figure casts toward the abyss;a child kneels, and alights.momentarily the boy stares.while he captures the lake;a child kneels, and alights.frozen, a child turns away.as the shadowy figure damns the abyss;the shadowy figure pauses, while breathing expectantly.frozen, the shadowy figure hesitates.momentarily the boy stares at the abyss;the boy returns, and hesitates.while a child lingers.while a child casts toward a darkness;the boy hesitates, and kneels.as the boy pauses.while he damns a star;the boy returns, and returns.as she hesitates.momentarily the boy outlines a cloud;the boy kneels, and alights.as the boy kneels.as the boy casts toward a abyss;the boy pauses, and turns away.frozen, she hesitates.while the boy damns a sky;she returns, and kneels.frozen, a child turns away.frozen, the boy casts toward the moon;the shadowy figure hesitates, while breathing slowly.momentarily he turns away.frozen, the shadowy figure stares at the lake;the shadowy figure lingers, while pointing with fear.while he lingers.momentarily a child casts toward the moon;the shadowy figure pauses, but turns away.as the shadowy figure returns.as she captures the darkness;she hesitates, and turns away.momentarily she hesitates.while the shadowy figure outlines a abyss;he returns, while pointing slowly.as he kneels.while a child outlines the lake;a child reflects, and reflects.momentarily the boy lingers.as a child stares at a void;the shadowy figure hesitates, and alights.while a child lingers.momentarily a child captures a star;he turns away, and hesitates.as he lingers.while the boy outlines a abyss;the boy pauses, and alights.frozen, she stares.as a child outlines a void;the shadowy figure lingers, but reflects.momentarily the boy lingers.frozen, the boy casts towa;the boy kneels, but stares.frozen, the boy kneels.momentarily he casts toward the lake;a child turns away, while pointing silently.momentarily he kneels.while he damns a moon;a child hesitates, while waiting darkly.as the shadowy figure returns.momentarily the shadowy figure casts toward a void;a child returns, and reflects.frozen, a child pauses.frozen, the shadowy figure damns a void;a child reflects, and turns away.while a child lingers.as the boy outlines a star;the boy turns away, and pauses.frozen, a child reflects.momentarily a child damns the star;she turns away, while pointing slowly.momentarily a child hesitates.frozen, the boy stares at a void;the boy pauses, but reflects.frozen, the shadowy figure hesitates.as he casts toward a moon;the shadowy figure stares, but kneels.momentarily a child stares.as the boy captures a cloud;he turns away, but pauses.while the boy returns. :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:stand:scan.out
----> &null221144332211443311every write(("badc" | "edgf" | "x") ? write(upto(!&lcase))) ----> none155every write((("aeiou" | "foobaz") ? upto('dracula')) ? =(1 to 10)) ----> none1234567891every write((1 to 10) ? move(1)) ----> none&subject := &pos ----> "1"&pos :=: &subject ----> 1&pos ----> 1&subject ----> "1"+1 ----> 1-1 ----> -1?10 ----> 3?10 ----> 5?10 ----> 4~&cset ----> ''~&ascii ----> '\x80\x81\x82\x83\x84\x85\x86\x87\x88\x89\x8a\x8b\x8c\x8d\x8e\x8f\x90\x91\x92\x93\x94\x95\x96\x97\x98\x99\x9a\x9b\x9c\x9d\x9e\x9f\xa0\xa1\xa2\xa3\xa4\xa5\xa6\xa7\xa8\xa9\xaa\xab\xac\xad\xae\xaf\xb0\xb1\xb2\xb3\xb4\xb5\xb6\xb7\xb8\xb9\xba\xbb\xbc\xbd\xbe\xbf\xc0\xc1\xc2\xc3\xc4\xc5\xc6\xc7\xc8\xc9\xca\xcb\xcc\xcd\xce\xcf\xd0\xd1\xd2\xd3\xd4\xd5\xd6\xd7\xd8\xd9\xda\xdb\xdc\xdd\xde\xdf\xe0\xe1\xe2\xe3\xe4\xe5\xe6\xe7\xe8\xe9\xea\xeb\xec\xed\xee\xef\xf0\xf1\xf2\xf3\xf4\xf5\xf6\xf7\xf8\xf9\xfa\xfb\xfc\xfd\xfe\xff'&subject := string(&lcase) ----> "abcdefghijklmnopqrstuvwxyz"="a" ----> "a"="b" ----> "b"="d" ----> none&subject := string(&lcase) ----> "abcdefghijklmnopqrstuvwxyz"abcdefghijklmnopqrstuvwxyzwhile write(move(1)) ----> none&subject := string(&lcase) ----> "abcdefghijklmnopqrstuvwxyz"aababcabcdabcdeabcdefabcdefgabcdefghabcdefghievery write(tab(1 to 10)) ----> nonepos(0) ----> nonepos(15) ----> none&subject := string(&lcase) ----> "abcdefghijklmnopqrstuvwxyz"pos(1) ----> 1aababcabcdabcdeabcdefevery write("abcdef" ? tab(1 to 10)) ----> noneevery write("abcde" ? while move(2) ? move(1)) ----> nones := "abcdef" ----> "abcdef"s ?:= move(3) ----> "abc"s := "abcdef" ----> "abcdef"123456every write(s ?:= upto(&lcase)) ----> nones := "this is the time to work it all out" ----> "this is the time to work it all out"thisthis isthis is thethis is the timethis is the time tothis is the time to workthis is the time to work itthis is the time to work it allevery write(s ? tab(find(" "))) ----> nones := "xxxxxx" ----> "xxxxxx"xevery s ? write(=("a" | "x")) ----> nonefedcba"abcdef" ? (tab(0) & (while write(move(-1)))) ----> none :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:stand:sieve.out
There are 25 primes in the first 100 integers.The primes are: 2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71 73 79 83 89 97 :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:stand:speller.out
1 one2 two3 three4 four5 five6 six7 seven8 eight9 nine10 ten11 eleven12 twelve21 twenty-one22 twenty-two23 twenty-three24 twenty-four25 twenty-five33 thirty-three36 thirty-six39 thirty-nine42 forty-two45 forty-five48 forty-eight51 fifty-one54 fifty-four57 fifty-seven63 sixty-three66 sixty-six69 sixty-nine72 seventy-two75 seventy-five78 seventy-eight81 eighty-one84 eighty-four87 eighty-seven93 ninety-three96 ninety-six99 ninety-nine102 one hundred and two105 one hundred and five108 one hundred and eight945123342 nine hundred and forty-five million and forty-five million and five million and one hundred and twenty-three thousand and twenty-three thousand and three thousand and three hundred and forty-two10000000 ten million10000007 ten million and seven10000021 ten million and twenty-one10000028 ten million and twenty-eight10000035 ten million and thirty-five10000042 ten million and forty-two10000049 ten million and forty-nine10000056 ten million and fifty-six10000063 ten million and sixty-three10000077 ten million and seventy-seven10000084 ten million and eighty-four10000091 ten million and ninety-one10000098 ten million and ninety-eight10000105 ten million and one hundred and five10000112 ten million and one hundred and twelve10000126 ten million and one hundred and twenty-six10000133 ten million and one hundred and thirty-three10000147 ten million and one hundred and forty-seven10000154 ten million and one hundred and fifty-four10000161 ten million and one hundred and sixty-one10000168 ten million and one hundred and sixty-eight10000175 ten million and one hundred and seventy-five10000182 ten million and one hundred and eighty-two10000189 ten million and one hundred and eighty-nine10000196 ten million and one hundred and ninety-six10000203 ten million and two hundred and three10000210 ten million and two hundred and ten10000224 ten million and two hundred and twenty-four10000231 ten million and two hundred and thirty-one10000238 ten million and two hundred and thirty-eight10000245 ten million and two hundred and forty-five10000252 ten million and two hundred and fifty-two10000259 ten million and two hundred and fifty-nine10000266 ten million and two hundred and sixty-six10000273 ten million and two hundred and seventy-three10000287 ten million and two hundred and eighty-seven10000294 ten million and two hundred and ninety-four10000301 ten million and three hundred and one10000308 ten million and three hundred and eight10000322 ten million and three hundred and twenty-two10000329 ten million and three hundred and twenty-nine10000336 ten million and three hundred and thirty-six10000343 ten million and three hundred and forty-three10000357 ten million and three hundred and fifty-seven10000364 ten million and three hundred and sixty-four10000371 ten million and three hundred and seventy-one10000378 ten million and three hundred and seventy-eight10000385 ten million and three hundred and eighty-five10000392 ten million and three hundred and ninety-two10000399 ten million and three hundred and ninety-nine10000406 ten million and four hundred and six10000427 ten million and four hundred and twenty-seven10000434 ten million and four hundred and thirty-four10000441 ten million and four hundred and forty-one10000448 ten million and four hundred and forty-eight10000455 ten million and four hundred and fifty-five10000462 ten million and four hundred and sixty-two10000469 ten million and four hundred and sixty-nine10000476 ten million and four hundred and seventy-six10000483 ten million and four hundred and eighty-three10000497 ten million and four hundred and ninety-seven :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:stand:string.out
----> &nulls := "abcd" ----> "abcd"s := "x" ----> "x"s ||:= "x" ----> "xx"s ----> "xx"s := "x" ----> "x"s ||:= "xx" ----> "xxx"s ----> "xxx"s := "x" ----> "x"s ||:= "X" ----> "xX"s ----> "xX"s := "x" ----> "x"s ||:= "abc" ----> "xabc"s ----> "xabc"s := "x" ----> "x"s ==:= "x" ----> "x"s ----> "x"s := "x" ----> "x"s ==:= "xx" ----> nones ----> "x"s := "x" ----> "x"s ==:= "X" ----> nones ----> "x"s := "x" ----> "x"s ==:= "abc" ----> nones ----> "x"{s[1:2] := "xx";s} ----> "xx"{s[-1:0] := "";s} ----> "x"{s[1] := "abc";s} ----> "abc"{s[1+:2] := "y";s} ----> "yc"{s[2] :=: s[3];s} ----> "yc"s[6] := "t" ----> nones[0-:6] := "u" ----> none{s[1:0] :=: s[0:1];s} ----> "yc""x" << "x" ----> none"x" << "X" ----> none"X" << "x" ----> "x""xx" <<= "xx" ----> "xx""xxx" <<= "xx" ----> none"xx" <<= "xxx" ----> "xxx""x" >>= "x" ----> "x""x" >>= "xx" ----> none"xx" >>= "x" ----> "x""x" >> "x" ----> none"x" >> "X" ----> "X""X" >> "x" ----> none"x" == "x" ----> "x""x" == "X" ----> none"X" == "x" ----> none"x" ~== "x" ----> none"x" ~== "X" ----> "X""X" ~== "x" ----> "x"222222222222222222222222222222222222222222222every i := 1 to 9 do write(integer(repl("2",i))) ----> none323223222322223222223222222322222223222222223every i := 1 to 9 do write(repl("2",i) + 1) ----> none222222222222222222222222222222every i := 1 to 30 do write(integer(repl("0",i) || "2")) ----> none333333333333333333333333333333every i := 1 to 30 do write((repl("0",i) || "2") + 1) ----> nonec1 := 'abcde' ----> 'abcde'c2 := 'aeuoi' ----> 'aeiou'c1 ++ c2 ----> 'abcdeiou'c1 -- c2 ----> 'bcd'c1 ** c2 ----> 'ae'2 ~=== +2 ----> none3 ~=== *"abc" ----> none'abc' ~=== ('abc' ++ '') ----> noneany('aeiou',&lcase) ----> 2any('aeiou',&ucase) ----> none2222222222266666666666every write(any('aeiou',&lcase,1 to 5,10 to 20)) ----> nonematch("abc","abcabcabcabc") ----> 4match("abc","xabcabcabcabc") ----> none555555588855585858every write(match("abc","xabcabcabcabc",1 to 10,1 to 10)) ----> noneupto('56d&',&lcase) ----> 4upto('56d&',&ucase) ----> noneupto('56d&',&lcase,15) ----> nonemany(&lcase,"this is a Test") ----> 5many(&lcase,"this is a Test",5) ----> nonemany(&lcase,"this is a Test",5,9) ----> nonefind("aa","xxaaaaaa") ----> 334567every write(find("aa","xxaaaaaa")) ----> none45every write(find("aa","xxaaaaaa",4,7)) ----> nonebal('-','(',')',"-35") ----> 1bal('+','(',')',"((2*x)+3)+(5*y)") ----> 10107710every write(bal('+','(',')',"((2*x)+3)+(5*y)",1 to 10)) ----> nonebal('+','[','[',"[[2*x[+3[+[5*y[") ----> nonebal('+','([','])',"([2*x)+3]+(5*y]") ----> 10bal(,,,"()+()") ----> 1bal(&cset,,,"()+()") ----> 1 :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:stand:struct.out
co-expression_1(1)main local identifiers: a = 1 x = 2 y = 3global identifiers: main = procedure main variable = function variable display = function display write = function write :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:stand:version7.out
if "{iconsize}" == "" export iconsize blocksize strsize set iconsize 1500000 set blocksize 600000 set strsize 600000endfor subtest in {"parameters"} echo -n "Translating {subtest} -- " set istart `date -n` icont -s "{subtest}" set iend `date -n` echo "`evaluate {iend} - {istart}` seconds" echo -n "Running {subtest} -- " set exit 0 set datafile "{subtest}".dat set istart `date -n` if `exists "{datafile}"` "{subtest}" < "{datafile}" ∑ ":local:{subtest}.out" else "{subtest}" ∑ ":local:{subtest}.out" end set iend `date -n` echo "`evaluate {iend} - {istart}` seconds" echo "Checking {subtest} output" compare -n ":local:{subtest}.out" ":stand:{subtest}.out" delete "{subtest}"endexit 0 :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:TestAll
for xtest in ≈.lst evaluate x = "{xtest}" =~ /(≈)®1.lst/ set testname "{®1}" TestSet "{testname}"end :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:TestSet
for testname in {"parameters"} echo "Performing test set: ∂"{testname}∂"" for subtest in `catenate "{testname}.lst"` Test "{subtest}" endend :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:tracer.dat
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:tracer.icn
global sprocedure main() &trace := -1 s := "abcdef" &subject := "123456" &pos := 4 every tracer(1) every foo(&pos | &subject | &pos[1] | &subject[2:5])endprocedure tracer(a) local i static j i := 2 j := 3 suspend a | i | j | s | &subject | &pos | &random | &trace | &subject[3:4] | &pos[1] | s[3] | s[3:5] | &random[1] | &trace[1] | &subject[2:5][1]endprocedure foo(s) return send :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:tranlink.lst
hellobtreesproto :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:transmit.dat
Version 7 of Icon corrects a number of problemswith co-expressions that existed in previousversions. The most significant one is properhandling of co-expression return points. :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:transmit.icn
global words, lines, writerprocedure main() if not(&features == "co-expressions") then stop("co-expressions not supported") &trace := -1 words := create word() lines := create reader() writer := create output() @writerendprocedure word() static letters initial letters := &lcase ++ &ucase while line := @lines do line ? while tab(upto(letters)) do tab(many(letters)) @ writerendprocedure reader() while read() @ wordsendprocedure output() while write(&errout,@words) @&mainend :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:var.dat
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:var.icn
procedure main(a) local x static y variable("a") := 1 variable("x") := 2 variable("y") := 3 display() if variable("z") then write("oops")end :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:version7.dat
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:version7.icn
procedure main () write(&host) write(&version) write("&line=",&line) write("&file=",&file) write("&error=",&error) every write(&features)# show results of bitwise operations on various operand combinations every i := 1 | '2' | "3" do { write ( " i j ~j i & j i | j i ^ j i << j i >> j") every j := 0 | 1 | 2 | 3 | 4 | 100 do { write(right(i,8), right(j,9)) word (i) word (j) word (icom (j)) word (iand (i, j)) word (ior (i, j)) word (ixor (i, j)) word (ishift (i, j)) word (ishift (i, -j)) write () } }# test remove() and rename(), and print errors in case of malfunction name1 := "temp1" name2 := "temp2" data := "Here's the data" every remove (name1 | name2) # just in case open (name1) & stop ("can't remove ", name1, " to initialize test") open (name2) & stop ("can't remove ", name2, " to initialize test") remove (name1) & stop ("successfully removed nonexistent file") rename (name1, name2) & stop ("successfully renamed nonexistent file") f := open (name1, "w") | stop ("can't open ",name1," for write") write (f, data) close (f) f := open (name1) | stop ("can't open ",name1," after write") s := read (f) | "" close(f) s == data | stop ("data lost after write") rename (name1, name2) | stop ("can't rename(",name1,",",name2,")") f := open (name2) | stop ("can't open ",name2," after rename") s := read (f) | "" close(f) s == data | stop ("data lost after rename") remove (name1) & stop ("remove succeeded on file already renamed") remove (name2) | stop ("can't remove renamed file") open (name1) & stop (name1, " still around at end of test") open (name2) & stop (name2, " still around at end of test")# test seek() and where() f := open("concord.dat") write(image(seek(f,11))) write(where(f)) write(image(reads(f,10))) write(where(f)) write(where(f)) seek(f,-2) write(where(f)) write(image(reads(f,1))) write(where(f))# test ord() and char(), and print messages if wrong results s := string (&cset) every i := 0 to 255 do { c := char (i) n := ord (c) if n ~= i | c ~== s[i+1] then write ("oops -- ord/char failure at ",i) } if char("47") ~== char(47) then write ("oops -- type conversion failed in char()") if ord(9) ~= ord("9") then write ("oops -- type conversion failed in ord()") every ferr (char, -65536 | -337 | -1 | 256 | 4713 | 65536 | 123456, 205) every ferr (char, "abc" | &lcase | &errout | [], 101) every ferr (ord, "" | "ab" | "antidisestablishmentarianism" | 47, 205) every ferr (ord, &output | table(), 103)# test getenv() write(getenv("HOME") | write("getenv failed")) write(getenv("foo") | write("getenv failed"))# test sorting a := list(1) # different sizes to make identification easy b := list(2) c := list(3) d := list(4) e := &lcase ++ &ucase f := &lcase ++ &ucase g := '123456789' h := &digits A := sort([h,g,a,c,b,d,f,e,&lcase,[],&cset,&ascii]) every write(image(!A))# test varargs write("p(1):") p(1) write("p(1, 2):") p(1, 2) write("p(1, 2, 3):") p(1, 2, 3) write("p(1, 2, 3, 4, 5):") p(1, 2, 3, 4, 5) write("q(1, 2):") q(1, 2)# test Version 7 table features write("t := table(\"default\") --> ", image(t := table("default")) | "failure") show(t) write("insert(t, 3, 4) --> ", image(insert(t, 3, 4)) | "failure") write("insert(t, \"xyz\", \"abc\") --> ", image(insert(t, "xyz", "abc")) | "failure") write("insert(t, &digits) --> ", image(insert(t, &digits)) | "failure") show(t) write("t[\"xyz\"] := \"new value\" --> ", image(t["xyz"] := "new value") | "failure") show(t) write("insert(t, \"xyz\", \"def\") --> ", image(inseyz", "def")) | "failure") show(t) write("delete(t, \"xyz\") -- > ", image(delete(t, "xyz")) | "failure") show(t) write("delete(t, \"xyz\") -- > ", image(delete(t, "xyz")) | "failure") show(t)# test run-time error mechanism &error := 1 runerr(101) write("&errornumber=", &errornumber | "no value") write("&errortext=", &errortext | "no value") write("&errorvalue=", &errorvalue | "no value") runerr(701,"abc")end# write word in hexadecimalprocedure word (v) xd (v, 8) writes (" ") return end# write n low-order hex digits of vprocedure xd (v, n) xd (ishift (v, -4), 0 < n - 1) writes ("0123456789ABCDEF" [1 + iand (v, 16r0F)]) return end# ferr(func,val,err) -- call func(val) and verify that error "err" is producedprocedure ferr (func, val, err) msg := "oops -- " || image(func) || "(" || image (val) || ") " &error := 1 if func (val) then write (msg, "succeeded") else if &error ~= 0 then write (msg, "failed but no error") else if &errornumber ~= err then write (msg, "got error ",&errornumber," instead of ",err) &error := 0 returnendprocedure p(a, b, c[]) write(" image(a):", image(a)) write(" image(b):", image(b)) write(" image(c):", image(c)) write(" every write(\"\\t\", !c):") every write("\t", !c)endprocedure q(a[]) write(" every write(\"\\t\", !a):") every write("\t", !a)endprocedure show(t) local x write(" *t --> ", *t) write(" t[\"xyz\"] --> ", image(t["xyz"]) | "failure") write(" member(t, \"xyz\") --> ", image(member(t, "xyz")) | "failure") x := sort(t, 3) write(" contents of t:") while writes("\t", image(get(x)), " : ") do write(image(get(x))) write("")end :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:version8.dat
:MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:version8.icn
procedure main(L) write(image(&letters)) write(image(L)) write(image(&main)) write(args(main)) write(args(write))## The following should do nothing unless memory mointoring is enabled. mmout("testing, testing") mmpause() mmshow([])end :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:wordcnt.dat
## W O R D T A B U L A T I O N## This main procedure processes standard input and writes the results# with the words in a column 20 characters wide.procedure main() wordcount(20)endprocedure wordcount(n) local t, line, x, y static letters initial letters := &lcase ++ &ucase t := table(,0) every line := !&input do scan line using while tab(upto(letters)) do t[tab(many(letters))] +:= 1 x := sort(t) every y := !x do write(left(y[1],n),y[2])end :MPW:MPW Tools:Tools with Source:Icon 8.0 Source ƒ:tests:wordcnt.icn
## W O R D C O U N T I N G## This program tabulates the words in standard input and writes the# results with the words in a column 20 characters wide. The definition# of a "word" is naive.procedure main() wordcount(20)endprocedure wordcount(n) local t, line, x, i static letters initial letters := &lcase ++ &ucase t := table(0) while line := read() do line ? while tab(upto(letters)) do t[tab(many(letters))] +:= 1 x := sort(t,3) every i := 1 to *x - 1 by 2 do write(left(x[i],n),x[i + 1])end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Folder:data:a2n.csg
# a(2(n))# Salomaa, pp. 13-14#G->YXYYX->YZ2:ZX->XXZ2:ZY->XXYX->aY->G:20 :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldabc.csg
# a(n)b(n)c(n)# Salomaa, p. 11.# Attributed to M. Soittola.#X->abcX->aYbcYb->bYYc->ZbccbZ->ZbaZ->aaYaZ->aaX:10 :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldabcd.csg
# a(n)b(n)c(n)d(n)# Fu, p. 94-95.S->aABA->aACA->DDc->cDDd->dDDC->ECEC->EdDB->FBEd->GdcG->GcdG->GdaG->abcDbG->bbcDdFB->dFddFd->FddcF->FcbF->bbcaF->abbB->bcdS:5 :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldadd.lbl
#kFirst Address 80973-000#Second AddressSomewhere, USA 09321#Third Address -- with no zipcode ---#Fourth AddressP.O. Box 78321Nowhere 83211 :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldan2.csg
# a(n(2))# Salomma, pp. 12-13. Attributed to M. Soittola.#2:G->aG->aXBZ2:BZ->aa2:Xa->aa2:Ya->aaBZ->CYXZXA->AYXYA->CYXXC->AYYC->CYaA->aXXYBBY->XDDY->YDDX->YBG:10 :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldbb3.tur
Order, Coleoptera, (Beetles). Many beetles are colored so asto resemble the surfaces which they habitually frequent, and they thusescape detection by their enemies. Other species, for instance, diamond-beetles, are ornamentedwith splendid colors, which are often arranged in stripes, spots, crosses,and other elegant patterns. Such colors can hardly serve directly as a protection, except in the caseof certain flower-feeding species; but they may serve as a warning or means ofrecognition, on the same principle as thephosphorescence of the glow-worm.As with beetles the colors of the two sexes are generally alike, we haveno evidence that they have been gained through sexual selection; but this isat least possible, for they may have been developed in one sex and thentransferred to the other; and this view is even in some degree probablein those groups which possess other well-marked secondarysexual characters. Blind beetles, which cannot, of course, behold eachother's beauty, never, as I hear from Mr. Waterhouse, Jr., exhibit brightcolors, though they often have polished coats; but the explanation of theirobscurity may be that they generally inhabit caves and other obscure stations. :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Folddickens.txt
It was the best of times, it was the worst of times, it was the age ofwisdom, it was the age of foolishness, it was the epoch of belief, it wasthe epoch of incredulity, it was the season of Light, it wasthe season of Darkness, it was the spring of hope, it was the winterof dispair, we had everything before us, we had nothing before us, wewere all going direct to Heaven, we were all going direct the otherway -- in short, the period was so far like the present period, that someof its noisiest authorities insisted on its being received, for good orfor evil, in the superlative degree of comparison only. :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldegg.krs
andeggplantselephantspurple :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldexp.rsg
<expr>::=<term>|<term>|<term>|<term>+<expr><term>::=<elem>|<elem>|<elem>*<term><elem>::=<'xyz'>|<'0123'>|(<expr>)<expr>30 :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldfarber.sen
A buck in the hand is worth two on the books.A carpenter's son doesn't have shoes.A dog under any other coat is still a dog.A hand in the bush is worth two anywhere else.A lot of these arguments are fetious.A lot of things are going to be bywashed.A lot of water has gone over the bridge since then.A problem swept e table occasionally comes home to roost.A rocky road is easier to travel than a stone wall.A stop-gap measure is better than no gap at all.A whole hog is better than no hole at all.Abandon ship all you who enter here!After that, we'll break our gums on the computer.All the hills of beans in China don't matter.All the lemmings are coming home to roost.All the lemmings are going home to roost.All you have to do is fill in the missing blanks.An avalanche is nipping at their heels.An enigma is only as good as it's bottom line.An ounce of prevention is better than pounding the table.And I take the blunt of it!Another day, a different dollar.Any kneecap of yours is a friend of mine.Any storm in a port.Anybody who marries her would stand out like a sore thumb.Anything he wants is a friend of mine.Are there any problems we haven't beat out to death?As long as somebody let the cat out of the bag, we might as well spell it correctly.At the end of every pot of gold, there's a rainbow.Before they made him they broke the mold.Beware a Trojan bearing a horse.Boulder dash!By a streak of coincidence, it really happened.By the time we unlock the bandages, he will have gone down the drain.Cheapness doesn't come free.Clean up or fly right.Clean up your own can of worms!Come down off your charlie horse.Conceptual things are in the eye of the beholder.Dig a hole and bury it.Dig yourself a hole and bury it.Do it now; don't dingle-dally over it.Do not fumble with a woman's logic.Does it joggle any bells?Don't bite the hand that stabs you in the back.Don't burn your bridges until you come to them.Don't cash in your chips until the shill is down.Don't cast a gander upon the water.Don't cast any dispersions.Don't cast doubts on troubled waters.Don't count your chickens until the barn door is closed.Don't criticize him for lack of inexperience.Don't cut off the limb you've got your neck strung out on.Don't do anything I wouldn't do standing up in a hammock.Don't eat with your mouth full.Don't get your eye out of joint.Don't jump off the gun.Don't jump off the handle.Don't jump on a ship that's going down in flames.Don't just stand there like a sitting duck.Don't lead them down the garden path and cut them off at the knees.Don't leave the nest that feeds you.Don't let the camels get their feet in the door.Don't look a gift horse in the face.Don't look a mixed bag in the mouth.Don't look at me in that tone of voice.Don't look for a gift in the horse's mouth.Don't make a molehill out of a can of beans.Don't make a tempest out of a teapot.Don't muddle the waters.Don't pull a panic button.Don't pull an enigma on me.Don't put all you irons on the fire in one pot.Don't rattle the boat.Don't rock the boat that feeds you.Don't roll up your nostrils at me.Don't stick your oar in muddy waters.Don't strike any bells while the fire is hot.Don't talk to me with your clothes on.Don't throw the baby out with the dishwasher.Don't throw the dog's blanket over the horse's nose.Don't twiddle your knee-caps at me!Don't upset the apple pie.Dot your t's and cross your i's.Each of us sleazes by at our own pace.Erase that indelibly from your memory.Every cloud has a blue horizon.Every rainbow has a silver lining.Everything is going all bananas.Everything is ipso facto.Everything is mutually intertangled.Everything's all ruffled over.Fade out in a blaze of glory.Feather your den with somebody else's nest.Fellow alumni run thicker than water.Fish or get off the pot!Float off into several individual conferees.For all intensive purposes, the act is over.From here on up, it's down hill all the way.Gander your eye at that!Gee, it must have fallen into one of my cracks.Get off the stick and do something.Get the hot poop right off the vine.Getting him to do anything is like pulling hen's teeth.Give him a project to get his teeth wet on.Give him a square shake.Give him an inch and he'll screw you.Give him enough rope and he will run away with it.Go fly your little red wagon somewhere else.Good grace is in the eye of the beholder.Good riddance aforethought.Half a loaf is better than two in the bush.Half a worm is better than none.Have it prepared under my signature.Have more discretion in the face of valor.Have the seeds we've sown fallen on deaf ears?Have we been cast a strange eye at?Have we gone too fast too far?He and his group are two different people.He came in on my own volition.He can't hack the other can of worms.He choked on his own craw.He deserves a well-rounded hand of applause.He didn't even bat an eyebrow.He didn't flinch an eyelid.He disappeared from nowhere.He doesn't have the brain to rub two nickels together.He doesn't know which side his head is buttered on.He drinks like a sieve.He flipped his cork.He gave me a blanket check.He got taken right through the nose.He got up on his highheels.He grates me the wrong way.He has a dire need, actually it's half-dire, but he thinks it's double-dire.He has a marvelous way of extruding you.He has a very weak indigestion.He has a wool of steel.He has feet of molasses.He has his ass on the wrong end of his head.He has his crutches around her throat.He has his foot in the pie.He has his neck out on a limb.He has his pot in too many pies.He has the character of navel lint.He has the courage of a second-story man.He hit the nose right on the head.He is as dishonest as the day is long.He just sat there like a bump on a wart.He keeps his ear to the vine.He knows which side his pocketbook is buttered on.He knows which side of his bread his goose is buttered on.He may be the greatest piece of cheese that ever walked down the plank.He needs to get blown out of his water.He popped out of nowhere like a jack-in-the-bean-box.He pulled himself up on top of his own bootstraps.He rammed it down their ears.He reads memos with a fine tooth comb.He rules with an iron thumb.He said it thumb in cheek.He should be gracious for small favors.He smokes like a fish.He wants to get his nose wet in several areas.He was hoisted by a skyhook on his own petard!He was hoisted by his own canard.He was hung by his own bootstraps.He was left out on the lurch.He was putrified with fright.He wears his finger on his sleeve.He would forget his head if it weren't screwed up.He'll get his neck in hot water.He'll grease any palm that will pat his ass.He's a bulldog in a china shop.He's a fart off the old block.He's a lion in a den of Daniels.He's a little clog in a big wheel.He's a shirking violet.He's a young peeksqueek.He's as crazy as a bloody loon!He's as crazy as a fruitcake.He's as happy as a pig at high tide.He's as quick as an eyelash.He's bailing him out of the woods.He's been living off his laurels for years.He's being pruned for the job.He's being shifted from shuttle to cock.He's biting the shaft and getting the short end of the problem.He's breathing down my throat.He's casting a red herring on the face of the water.He's clam bait.He's cornered on all sides.He's faster than the naked eye.He's fuming at the seams.He's going to fall flat on his feet.He's got a rat's nest by the tail.He's got a tough axe to hoe.He's got four sheets in the wind.He's got his intentions crossed.He's got so much zap he can barely twitch.He's king bee.He's letting ground grow under his feet.He's like a wine glass in a storm.He's like sheep in a bullpen.He's lying through his britches.He's not breathing a muscle.He's off in a cloud of ``hearty heigh-ho Silver''.He's on the back of the pecking order.He's one of the world's greatest flamingo dancers.He's paying through the neck.He's procrastinating like a bandit.He's reached the crescent of his success.He's restoring order to chaos.He's running around like a bull with his head cut off.He's running around like a chicken with his ass cut off.He's running around with his chicken cut off.He's running from gamut to gamut.He's running off at the seams.He's seething at the teeth.He's sharp as a whip.He's singing a little off-keel.He's so far above me I can't reach his bootstraps.He's so mad he is spitting wooden nickels.He's somewhere down wind of the .He's spending a lot of brunt on the task.He's splitting up at the seams.He's the best programmer east of the Mason-Dixon line.He's the king of queens.He's the last straw on the camel's back to be called.He's too smart for his own bootstraps.He's tossing symbols around like a percussionist in a John Philip Sousa band.He's up a creek with his paddles leaking.He's within eyeshot of shore.Heads are rolling in the aisles.His eyeballs perked up.His feet have come home to roost.His foot is in his mouth up to his ear.His head's too big for his britches.History is just a repetition of the past.Hold your cool!How old is your 2-year old?I accept it with both barrels.I apologize on cringed knees.I came within a hair's breathe of it.I can do it with one eye tied behind me.I can remember everything \(em I have a pornographic mind.I can't hum a straight tune.I case my ground very well before I jump into it.I come to you on bended bootstrap.I contributed to the charity of my cause.I could count it on the fingers of one thumb.I could tell you stories that would curdle your hair.I did it sitting flat on my back.I don't always play with a full house of cards.I don't know which dagger to clothe it in.I don't like the feel of this ball of wax.I don't want to be the pie that upset the applecart.I don't want to cast a pall on the water.I don't want to start hurdling profanity.I don't want to stick my hand in the mouth that's feeding me.I don't want to throw a wrench in the ointment.I enjoy his smiling continence.I flew it by ear.I got you by the nap of your neck.I guess I'd better get my duff on the road.I guess I'm putting all my birds in one pie.I guess that muddled the waters.I had her by the nap of the neck.I had to make a split decision.I had to scratch in the back recesses of my memory.I had to throw in the white flag.I have a green thumb up to my elbow.I have a rot-gut feeling about that.I have feedback on both sides of the coin.I have my neck hung out on an open line.I have no personal bones to grind about it.I have people crawling out of my ears.I have post-naval drip.I have reasonably zero desire to do it.I have the self-discipline of a mouse.I have to get my guts up.I have too many cooks in the pot already.I haven't bitten off an easy nut.I haven't gotten the knack down yet.I hear the handwriting on the wall.I heard it out of the corner of my eyes.I just pulled those out of the seat of my pants.I keep stubbing my shins.I know what we have to do to get our feet off the ground.I listen with a very critical eye.I looked at it with some askance.I march to a different kettle of fish.I only hear half of what I believe.I only hope your every wish is desired.I only mentioned it to give you another side of the horse.I only read it in snips and snabs.I owe you a great gratitude of thanks.I pulled my feet out from under my rug.I put all my marbles in one basket.I read the sign, but it went in one ear and out the other.I resent the insinuendoes.I rushed around like a chicken out of my head.I said it beneath my breath.I see several little worms raising their heads around the corner.I speak only with olive branches dripping from the corners of my mouth.I think I've committed a fore paw.I think he's gone over the bend.I think that we are making an out-and-out molehill of this issue.I think the real crux is the matter.I thought I'd fall out of my gourd.I want half a cake and eat it too.I want to embark upon your qualms.I want to get more fire into the iron.I want to get to know them on a face-to-name basis.I want to go into that at short length.I want to see him get a good hands-on feel.I was working my balls to the bone.I wish somebody could drop the other foot.I won't hang my laurels on it.I won't kick a gift horse in the mouth.I worked my toes to the bonenail.I would imagine he chafes a bit.I wouldn't give it to a wet dog.I wouldn't marry her with a twenty-foot pole.I wouldn't take him on a ten foot pole.I wouldn't want to be sitting in his shoes.I'd better get my horse on it's ass.I'd better jack up my bootstraps and get going.I'd have been bent out of shape like spades.I'd kill a dog to bite that man.I'd like to intersperse a comment.I'd like to put another foot into the pot.I'd like to strike while the inclination is hot.I'd rather be tight than right.I'll be ready just in case a windfall comes down the pike.I'll be there in the next foreseeable future.I'll be there with spades one.I'll bet there's one guy out in the woodwork.I'll descend on them to the bone.I'll fight him hand and nail.I'll hit him right between the teeth.I'll procrastinate when I get around to it.I'll reek the benefits.I'll see it when I believe it.I'll stay away from that like a 10-foot pole.I'll take a few pegs out of his sails.I'll take any warm body in a storm.I'm a mere fragment of my imagination.I'm all ravelled up.I'm basking in his shadow.I'm burning my bridges out from under me!I'm casting the dye on the face of the water.I'm collapsing around the seams.I'm creaking at the seams.I'm creaming off the top of my head.I'm deathly curious.I'm flapping at the gills.I'm going off tangentially.I'm going right out of my bonker.I'm going right over the bend.I'm going to cast my rocks to the wind.I'm going to down-peddle that aspect.I'm going to feel it out by the ear.I'm going to litigate it to the eyeballs.I'm going to put a little variety in your spice of life.I'm going to put my horn in.I'm going to read between your lines.I'm going to resolve it by ear.I'm going to scatter them like chaff before the wind.I'm going to scream right out of my gourd.I'm going to take my vendetta out on them.I'm going to take my venom out on you.I'm going to throw myself into the teeth of the gamut.I'm ground up to a high pitch.I'm having a hard time getting my handles around that one.I'm having a hard time getting my handles around that one.I'm in my reclining years.I'm in transit on that point.I'm listening with baited ears.I'm looking at it with a jaundiced ear.I'm not going to bail him out of his own juice.I'm not going to beat a dead horse to death.I'm not going to get side tracked onto a tangent.I'm not sure it's my bag of tea.I'm not sure we're all speaking from the same sheet of music.I'm not trying to grind anybody's axes.I'm out of my bloomin' loon.I'm over the hilt.I'm parked somewhere in the boondoggles.I'm pulling something over on you.I'm ready to go when the bell opens.I'm running around like a one-armed paper bandit.I'm signing my own death knell.I'm sitting on the edge of my ice.I'm smarting at the seams.I'm soaked to the teeth.I'm standing over your shoulder.I'm sticking my neck out on a ledge.I'm stone cold sane.I'm talking up a dead alley.I'm throwing those ideas to you off the top of my hat.I'm too uptight for my own bootstraps.I'm up a wrong alley.I'm up against a blind wall.I'm up to my earballs in garbage.I'm walking on cloud nine.I'm walking on thin water.I'm weighted down with baited breath.I'm willing to throw my two cents into the fire.I'm working my blood up into a fervor.I'm wound up like a cork
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Fold
+++++ Continued from previous card +++++
.I'm your frontface in this matter.I've been burning the midnight hours.I've built enough fudge into that factor.I've got applicants up to the ears.I've got to put my duff to the grindstone.I've had it up to the hilt.I've had more girls than you've got hair between your teeth.I've milked that dead end for all it's worth.I've worked my shins to the bone.If Calvin Coolidge were alive today, he'd turn over in his grave.If anything, I bend over on the backwards side.If the onus fits, wear it.If the shoe fits, put it in your mouth.If the shoe is on the other foot, wear it.If there's no fire, don't make waves.If they do it there won't be a living orgasm left.If they do that, they'll be committing suicide for the rest of their lives.If they had to stand on their own two feet, they would have gone down the drain a long time ago.If we keep going this way, somebody is going to be left standing at the church with his pants on.If you ask him he could wax very quickly on that subject.If you don't want words put in your mouth, don't leave it hanging open.If you listen in the right tone of voice, you'll hear what I mean.If you see loose strings that have to be tied down that are not nailed up, see me about it.If you want something bad enough, you have to pay the price.If you want to be heard, go directly to the horse's ear.If you want to get your jollies off, watch this!If you'd let me, I'd forget the shirt off my back.If you're going to break a chicken, you have to scramble a few eggs.In one mouth and out the other.In this period of time, its getting very short.In this vein I will throw out another item for Pandoras' box.Indiscretion is the better part of valor.Is he an Amazon!Is there any place we can pull a chink out of the log jam?It cuts like a hot knife through solid rock.It drove me to no wits end.It fills a well-needed gap.It floated right to the bottom.It flows like water over the stream.It gets grained into you.It goes from one gamut to another.It goes from tippy top to tippy bottom.It goes in one era and out the other.It goes out one ear and in the other.It got left out in the lurch.It has more punch to the unch.It hit me to the core.It hit the epitome of it.It is better to have tried and failed than never to have failed at all.It leaks like a fish.It looks like it's going to go on ad infinitum for a while.It looks real enough to be artificial.It may seem incredulous, but it's true.It might break the straw that holds the camel's back.It might have been a figment of my illusion.It rolls off her back like a duck.It runs the full width of the totem pole.It sounds like roses to my ears.It sure hits the people between the head.It was a heart-rendering decision.It was a maelstrom around his neck.It was deja vu all over again.It was oozing right out of the lurches.It was really amazing to see the spectra of people there.It went through the palm of my shoe.It will spurn a lot of furious action.It will take a while to ravel down.It' not an easy thing to get your teeth around.It's a Byzantine thicket of quicksand.It's a caterpillar in pig's clothing.It's a fiat accompli.It's a fool's paradise wrapped in sheep's clothing.It's a hairy banana.It's a hairy can of worms.It's a home of contention.It's a lot like recumbent DNA.It's a lot of passed water under the bridge.It's a mare's nest in sheep's clothing.It's a mecca of people.It's a monkey wrench in your ointment.It's a new high in lows.It's a road of hard knocks.It's a sight for sore ears.It's a slap in the chaps.It's a tempest in a teacup.It's a terrible crutch to bear.It's a tough nut to hoe.It's a tough road to haul.It's a travesty to the human spirit.It's a typical case of alligator mouth and hummingbird ass.It's a white elephant around my neck.It's a white herring.It's about 15 feet as the eye flies.It's about as satisfactory as falling off a log.It's all above and beyond board.It's all in knowing when to let a dead horse die.It's all water under the dam.It's always better to be safe than have your neck out on a limb.It's an ill wind that doesn't blow somebody.It's another millstone in the millpond of life.It's as easy as falling off a piece of cake.It's as easy as falling off a piece of cake.It's as flat as a door knob.It's as predictable as cherry pie.It's bouncing like a greased pig.It's burned to shreds.It's crumbling at the seams.It's enough to make you want to rot your socks.It's going to bog everybody up.It's going to fall on its ass from within.It's got all the bugs and whistles.It's hanging out like a sore tongue.It's like a greased pig in a wet blanket.It's like a knife through hot butter.It's like a raft on roller skates.It's like asking a man to stop eating in the middle of a starvation diet.It's like harnessing a hare to a tortoise.It's like pulling hen's teeth.It's like talking to a needle in a haystack.It's like the flood of the Hesperis.It's like trying to light a fire under a lead camel.It's like trying to squeeze blood out of a stone.It's more than the mind can boggle.It's music to your eyes.It's no chip off my clock.It's no sweat off my nose.It's not an easy thing to get your teeth wet on.It's not completely an unblessed advantage.It's not his bag of tea.It's not my Diet of Worms.It's not my cup of pie.It's not really hide nor hair.It's one more cog in the wheel.It's perfect, but it will have to do.It's raining like a bandit.It's right on the tip of my head.It's sloppy mismanagement.It's so unbelievable you wouldn't believe it.It's something you're all dying to wait for.It's the blind leading the deaf.It's the greatest little seaport in town.It's the old Paul Revere bit . . . one if by two and two if by one.It's the old chicken-in-the-egg problem.It's the other end of the kettle of fish.It's the straw that broke the ice.It's the the highest of the lows.It's the vilest smell I ever heard.It's under closed doors.It's within the pall of reason.It's wrought with problems.It's your ball of wax, you unravel it.Its coming down like buckets outside.Judas Proust!Just because it's there, you don't have to mount it.Just cut a thin slither of it.Just remember that, and then forget it.Keep the water as firm as possible until a fellow has his feet on the ground.Keep this under your vest.Keep your ear peeled!Keep your eyes geared to the situation.Keep your nose to the mark.Keep your nose to the plow.Lay a bugaboo to rest.Let he who casts the first stone cast it in concrete.Let him be rent from limb to limb.Let him fry in his own juice.Let it slip between the cracks.Let me clarify my fumbling.Let me feast your ears.Let me flame your fan.Let me say a word before I throw in the reins.Let me take you under my thumb.Let me throw a monkey into the wrench.Let me throw a monkey wrench in the ointment.Let sleeping uncertainties lie.Let them fry in their socks.Let them hang in their own juice.Let's bend a few lapels.Let's get down to brass facts.Let's go outside and commiserate with nature.Let's grab the initiative by the horns.Let's kick the bucket with a certain amount of daintiness.Let's kill two dogs with one bone.Let's look at it from the other side of the view.Let's lurch into the next hour of the show.Let's not drag any more dead herrings across the garden path.Let's not get ahead of the bandwagon.Let's not hurdle into too many puddles at once.Let's not open the skeleton in that closet.Let's play the other side of the coin.Let's put out a smeller.Let's raise our horizons.Let's roll up our elbows and get to work.Let's set up a straw vote and knock it down.Let's shoot holes at it.Let's skin another can of worms.Let's solve two problems with one bird.Let's strike the fire before the iron gets hot.Let's talk to the horse's mouth.Let's wreck havoc!Like the shoemaker's children, we have computers running out of our ears.Look at the camera and say `bird'.Look before you turn the other cheek.Man cannot eat by bread alone.May I inveigle on you?Men, women, and children first!My antipathy runneth over.My chicken house has come home to roost.My dog was pent up all day.My ebb is running low.My foot is going out of its mind.My head is twice its size.My mind is a vacuum of information.My mind went blank and I had to wait until the dust cleared.My off-the-head reaction is negative.My steam is wearing down.My stomach gets all knotted up in rocks.My train of thought went out to lunch.Necessity is the invention of strange bedfellows.Necessity is the mother of strange bedfellows.Never feed a hungry dog an empty loaf of bread.Never the twixt should change.No Californian will walk a mile if possible.No crumbs gather under his feet.No dust grows under her feet.No loaf is better than half a loaf at all.No moss grows on his stone.No one can predict the wheel of fortune as it falls.No problem is so formidable that you can't just walk away from it.No rocks grow on Charlie.No sooner said, the better.Nobody could fill his socks.Nobody is going to give you the world in a saucer.Nobody marches with the same drummer.Nobody's going to put his neck out on a limb.Nostalgia just isn't what it used to be.Not by the foggiest stretch of the imagination!Not in a cocked hat, you don't!Not in a pig's bladder you don't!Not me, I didn't open my peep.Not on your bootstraps!Now he's sweating in his own pool.Now the laugh is on the other foot!Now we have some chance to cut new water.One back scratches another.One doesn't swallow the whole cake at the first sitting.One man's curiosity is another man's Pandora's box.Our backs are up the wall.Our deal fell through the boards.Peanut butter jelly go together hand over fist.People in glass houses shouldn't call the kettle black.Picasso wasn't born in a day.Pick them up from their bootstraps.Pictures speak louder than words.Please come here ipso pronto.Pour sand on troubled waters.Put all your money where your marbles are.Put it in a guinea sack.Put it on the back of the stove and let it simper.Put that in your pocket and smoke it!Put the onus on the other foot.Put your mouth where your money is.Right off the top of my cuff, I don' know what to say.Right off the top of my hand, I'd say no.Roll out the Ouija ball.Rome wasn't built on good intentions alone.Row, row, row your boat, gently down the drain.See the forest through the trees.She had a missed conception.She had an aurora of goodness about her.She has eyes like two holes in a burnt blanket.She hit the nail on the nose.She looks like she's been dead for several years, lately.She makes Raquel Welch look like Twiggy standing backwards.She stepped full-face on it.She was sitting there with an insidious look on her face.She'll fight it tooth and toenail.She's a virgin who has never been defoliated.She's flying off the deep end.She's got a bee in her bonnet and just won't let it go.She's melting out punishment.She's steel wool and a yard wide.She's trying to feather her own bush.Shoot it up the flag pole.Somebody is going to have to take a forefront here.Somebody pushed the panic nerve.Somebody's flubbing his dub.Someone is going to be left in the church with his pants on.Sometimes I don't have both sails in the water.Speaking off the hand, I'd advise you to quit.Straighten up or fly right.Strange bedfellows flock together.Take care of two stones with one bird.Take it with a block of salt.That aspect permutes the whole situation.That curdles my toes.That curdles the milk of human kindness.That didn't amount to a hill of worms.That doesn't cut any weight with him.That job is at the bottom of the rung.That opens up a whole other kettle of songs.That problem is getting pushed into the horizon.That puts me up a worse creek.That really uprooted the apple cart.That solves two stones with one bird.That was a mere peanut in the bucket.That was almost half done unconsciously.That was like getting the horse before the barn.That was the corker in the bottle.That was the pan he was flashed in.That would drive him right out of his banana.That would have been right up Harry's meat.That'll take the steam out of their sails.That's a ball of another wax.That's a bird of a different color.That's a camel's eye strained through a gnat's tooth.That's a different jar of worms.That's a horse of a different feather.That's a matter for sore eyes.That's a measle-worded statement if I ever heard one.That's a sight for deaf ears.That's a tough nut to carry on your back.That's a two-edged circle.That's a whole new ballpark.That's an unexpected surprise.That's getting to the crotch of the matter.That's just putting the gravy on the cake.That's not my sack of worms.That's obviously a very different cup of fish.That's pushing a dead horse.That's the other end of the coin.That's the straw that broke the camel's hump.That's the wart that sank the camel's back.That's the way the old ball game bounces.That's the whole ball of snakes.That's the whole kettle of fish in a nutshell.That's the whole kettle of fish in a nutshell.That's their applecart, let them choke on it.That's water under the dam.That's way down in the chicken feed.That's when I first opened an eyelash.That's worse than running chalk up and down your back.The aggressor is on the wrong foot.The analogy is a deeply superficial one.The atmosphere militates against a solution.The ball is in our lap.The die has been cast on the face of the waters.The early bird will find his can of worms.The early worm catches the fish.The eggs we put all in one basket have come home to roost.The faculty has cast a jaundiced eye upon the waters.The fervor is so deep you can taste it.The foot that rocks the cradle is usually in the mouth.The fruits of our labors are about to be felt.The future is not what it used to be.The grass is always greener when you can't see the forest for the trees.The grocer's son always has shoes.The groundwork is thoroughly broken.The hand is on the wall.The horse is stolen before the barn even gets its door closed.The idea did cross my head.The ideas sprang full-blown from the hydra's heads.The initiative is on the wrong foot.The lights are so bright the air is opaque.The meeting was a first-class riot squad.The onus is on the other foot.The pipeline has ramped up.The restaurants are terrible \(em the town is completely indigestible.The sink is shipping.The up-kick of all that will be nothing.The viewpoints run from hot to cold.The whole thing is a hairy potpourri.The wishbone's connected to the kneebone.Their attitude is to let lying dogs sleep.There are enough cooks in the pot already.There are too many cooks and not enough indians.There are two sides to every marshmallow.There hasn't been much of a peep about it.There is a prolifery of new ideas.There is no surefool way of proceeding.There is one niche in his armor.There is some milk of contention between us.There was danger lurking under the tip of an iceberg.There were foot-high puddles.There will be fangs flying.There's a dark cloud on every rainbow's horizon.There's a flaw in the ointment.There's a little life in the old shoe yet.There's a lot of blanche here to carte.There's a lot of bull in the china shop.There's a lot of credibility in that gap!There's a strong over current here.There's a vortex swimming around out there.There's going to be hell and high water to pay.There's laughing on the outside, panelling on the inside.There's more than one way to skin an egg without letting the goose out of the bag.There's no place in the bowl for another spoon to stir the broth.There's no two ways around it.There's no
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Fold
+++++ Continued from previous card +++++
thing like stealing the barn door after the horse is gone.There's some noise afoot about the problem.There's some trash to be separated from the chaff.They are straining at nits.They are unscrupulously honest.They are very far and few between.They closed the doors after the barn was stolen.They descended on me like a hoar of locust.They don't like to dictate themselves to the problem.They don't see eye for eye with us.They don't stand a teabag's chance in hell.They fell all over their faces.They just want to chew the bull.They just want to shoot the fat.They locked the door after the house was stolen.They make strange bedfellows together.They rolled their eyebrows at me.They run across the gamut.They sucked all the cream off the crop.They sure dipsied his doodle.They unspaded some real down to earth data.They went after him tooth and fang.They wrecked havoc in the kitchen.They'll carve that spectrum any way we desire it.They're atrophying on the vine.They're colder than blue blazes.They're coming farther between.They're dropping his course like flies.They're dying off like fleas.They're eating out of our laps.They're germs in the rough.They're grasping for needles.They're spreading like wildflowers.They're very far and few between.They're working their bones off.They's chomping their lips at the prospect.They've beaten the bushes to death.They've got the bull by the tail now.They've reached a new level of lowness.Things are all up in a heaval.Things have slowed down to a terrible halt.Things keep falling out of it, three or four years at a time.This bit of casting oil on troubled feathers is more than I can take.This field of research is so virginal that no human eye has set foot on it.This ivory tower we're living in is a glass house.This office requires a president who will work right up to the hilt.This program has many weaknesses, but its strongest weakness remains to be seen.This thing kills me to the bone.This wine came from a really great brewery.This work was the understatement of the year.Those are good practices to avoid.Those guys are as independent as hogs on ice.Those guys weld a lot of power.Those people have no bones to grind.Those words were very carefully weasled.Time and tide strike but once.To be a leader, you have to develop a spear de corps.To coin a cliche, let's have at them.To sweeten the pie, I'll add some cash.To the cook goes the broth!Together again for the first time.Too many chiefs spoil the soup.Too many drinks spoil the broth.Too many hands spoil the soap.Trying to do anything is like a tour de force.Trying to get a doctor on Wednesday is like trying to shoot a horse on Sunday.Watch her \(em she gets on the stick very quickly.We are on equally unfooted ground.We are paying for the sins of serenity.We brought this can of worms into the open.We can clean ourselves right up to date.We can throw a lot of muscle into the pot.We can't get through the forest for the trees.We didn't know which facts were incorrect.We don't want to get enhangled in that either.We got another thing out of it that I want to heave in.We got on board at ground zero.We got the story post hoc.We have a difference of agreement.We have a real ball of wax to unravel.We have a real messy ball of wax.We have a wide range of broad-gauge people.We have achieved a wide specter of support.We threw everything in the kitchen sink at them.We're getting down to bare tacks.What can we do to shore up these problems?When the tough get going they let sleeping does lie.When they go downstairs, you can hear neither hide nor hair of them.When you're jumping on sacred cows, you've got to watch your step.You can make a prima donna sing, but you can't make her dance.You get more for your mileage that way.You gotta strike while the shoe is hot or the iron may be on the other foot.You have sowed a festering cowpie of suspicion.You put all your eggs before the horse.You really can't compare us -- our similarities are different.You've always been the bone of human kindness.Your wild oats have come home to roost. :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldgilbert.txt
My object all sublime I shall achieve in time --To let the punishment fit the crime -- The punishment fit the crime; And make each prisoner pent Unwillingly representA source of innocent merriment! Of innocent merriment! :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldgmr1.lin
0->1[0]1[0]01->11[->[]->]0:5 :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldgmr2.lin
0->1[0]1[0]01->110:5 :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldgmr3.lin
a->ab->abc->8 :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldgmr4.lin
1->2#33->2#44->5045->66->77->8(1)1:14 :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldicon.wrd
AcousticonIconicaaeolodiconaeolomelodiconammoniticoneAmphicondylaamphicondylousaniconicaniconismanticonceptionistanticonductoranticonfederationismanticonfederationistanticonfederativeanticonformistanticonformityanticonscienceanticonscriptionanticonscriptiveanticonservatismanticonservativeanticonservativelyanticonservativenessanticonstitutionanticonstitutionalanticonstitutionalismanticonstitutionalistanticonstitutionallyanticontagionanticontagionistanticontagiousanticontagiouslyanticontagiousnessanticonvellentanticonventionanticonventionalanticonventionalismanticonventionalistanticonventionallyanticonvulsiveapolloniconAppliconarchicontinentbactriticonebaculiticoneBalopticonbasiliconbiconcavebiconcavitybiconditionalbicondylarbiconebiconicbiconicalbiconicallybiconjugatebiconsonantalbiconnectbiconectivebiconsonanticbicontinuousbiconvexbreviconiccatholiconcerviconasalchroniconCiconiaCiconiaeciconianciconiidCiconiidaeciconiiformCiconiiformesciconineciconioidcubiconecubicontravariantcuprosilicondesiliconizationdesiliconizediaconicondiconduininedicondyliandicondylicdiconicdiconquininedicontdoxasticonectepicondylareireniconekasiliconentepicondylarepicondylarepicondyleepicondylianepicondylicepicontinentalepiopticonequiconvexethniconetymologiconeuphoniconferrosilicongeniconharmoniconHeliconheliconHeliconiaheliconiaHeliconianheliconianheliconideousheliconiiHeliconiidaeheliconiidaeHeliconiinaeheliconineheliconistHeliconiusheliconiusheliconoidheliopticonhydrauliconhydrosiliconiconiconantidypticiconfirmediconianiconiciconicaliconicallyiconicityiconismiconisticaliconisticallyIconiumiconiumiconizeiconocentericonoclasmiconoclasticonoclasticiconoclasticallyiconoclasticismiconoduleiconoduliciconodulisticonodulyiconogeneticiconographiconographericonographiciconographicaliconographicallyiconographisticonographyiconolagnyiconolatericonolatoriconolatrousiconolatryiconologicaliconologisticonologyiconomachiconomachaliconomachianiconomachicaliconomachisticonomachyiconomancyiconomaniaiconomaticiconomaticallyiconomaticismiconomatographyiconometericonometriciconometricaliconometricallyiconometryiconomicaliconomicariconophileiconophilismiconophilisticonophilyiconoplasticonoscopeiconostasiconostasioniconostasisiconostasiumiconotypeiconymusidioticonireniconkamptuliconlenticonuslexiconlexiconistlexiconizeliticontestationLogiconlongiconeLycopersiconmelodiconMiconmiconcaveMiconiaMiniconjoumnemoniconModiconmonasticonmulticonductormulticonstantnautiliconenoniconoclasticnoniconoclasticallyonomasticonOpiconsiviaopticonorganosiliconoriconicorthiconorthiconoscopeotacousticonPaiconecapanegyriconpanharmoniconpaniconographpaniconographicpaniconographypanmelodiconpanopticonpantechniconpericonchalpericonchitisplumbiconprotosiliconquadriconequasicondidentlyquasiconfidentquasiconfiningquasiconformingquasicongenialquasicongeniallyquasicongratulatoryquasiconnectivequasiconnectivelyquasiconscientiousquasiconscientiouslyquasiconsciousquasiconsequentialquasiconsequentiallyquasiconservativequasiconservativelyquasiconsideratequasiconsideratelyquasiconsistentquasiconsistentlyquasiconsolidatedquasiconstantquasiconstantlyquasiconstitutionalquasiconstitutionallyquasiconstrucitvelyquasiconstructedquasiconstructivequasiconsumingquasicontentquasicontentedquasicontentedlyquasicontinualquasicontinuallyquasicontinuousquasicontinuouslyquasicontrarilyquasicontraryquasicontrastedquasicontrolledquasicontrollingquasiconvenientquasiconvenientlyquasiconventionalquasiconventionallyquasiconvertedquasiconveyedquasiconvincedrariconstantRubiconrubiconrubiconedsalpiconsatyriconsciopticonscleroticonyxissemiconcavesemiconcealsemiconcealedsemiconcretesemiconditionedsemiconductingsemiconductionsemiconductivesemiconductorsemiconesemiconfidentsemiconfinementsemiconfluentsemiconformistsemiconformitysemiconicsemiconicalsemiconicallysemiconjugatesemiconnatesemiconnectionsemiconoidalsemiconscioussemiconsciouslysemiconsciousnesssemiconservativesemiconsonantsemiconsonantalsemiconspicuoussemicontinentsemicontinuoussemicontinuumsemicontractionsemicontradictionsemiconventionalsemiconventionallysemiconvergencesemiconvergentsemiconversionsemiconvertsiliconsiliconesiliconicsiliconizesiliconizingsiliconosilicononanestereopticonstibiconitesynonymiconsyodicontechnicontesticondtheologiconaturaltheoriconTiconderogatorticonetricontriconchTriconodontriconodontriconodontTriconodontatriconodontatriconodontidtriconodontivetriconodontoidtriconodontytriconsonantaltriconsonantalismtriconsonantictriconsonontaltrinopticonturriliticonetypicontyrotoxiconuniconoclasticuniconoclasticallyuniconstantvicondellviconianvicontvicontielvicontielsvidiconWiconiscotele-iconographmagniliconIconysisIconclassIconesAnticonfederacyanticonvulsanticonicsminiconjouICONICONSMICONDICONFICONsiliconiumIconhaNewviconSCICONpiconHelliconiaAmiconPiconetViconHeuriconminiconferenceSpectriconIconisDiconixLiconNecronomiconfansiconSiliconixInsecticonmicomiconDigiconDefiniconLogisticondecepticonviconOmniconZericonMacIconIconTrollerProIconFlexiconEroticonConiconiconogenitorsColiconiconopodIconAuthorIcon-It!IconerIconManagerIconMakerICONstructorSIL-ICON :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldiconproj.lbl
#Icon ProjectDepartment of Computer ScienceGould-Simpson BuildingThe University of ArizonaTucson, AZ 85721#Icon ProjectDepartment of Computer ScienceGould-Simpson BuildingThe University of ArizonaTucson, AZ 85721#Icon ProjectDepartment of Computer ScienceGould-Simpson BuildingThe University of ArizonaTucson, AZ 85721#Icon ProjectDepartment of Computer ScienceGould-Simpson BuildingThe University of ArizonaTucson, AZ 85721#Icon ProjectDepartment of Computer ScienceGould-Simpson BuildingThe University of ArizonaTucson, AZ 85721#Icon ProjectDepartment of Computer ScienceGould-Simpson BuildingThe University of ArizonaTucson, AZ 85721#Icon ProjectDepartment of Computer ScienceGould-Simpson BuildingThe University of ArizonaTucson, AZ 85721#Icon ProjectDepartment of Computer ScienceGould-Simpson BuildingThe University of ArizonaTucson, AZ 85721#Icon ProjectDepartment of Computer ScienceGould-Simpson BuildingThe University of ArizonaTucson, AZ 85721#Icon ProjectDepartment of Computer ScienceGould-Simpson BuildingThe University of ArizonaTucson, AZ 85721#Icon ProjectDepartment of Computer ScienceGould-Simpson BuildingThe University of ArizonaTucson, AZ 85721#Icon ProjectDepartment of Computer ScienceGould-Simpson BuildingThe University of ArizonaTucson, AZ 85721#Icon ProjectDepartment of Computer ScienceGould-Simpson BuildingThe University of ArizonaTucson, AZ 85721#Icon ProjectDepartment of Computer ScienceGould-Simpson BuildingThe University of ArizonaTucson, AZ 85721#Icon ProjectDepartment of Computer ScienceGould-Simpson BuildingThe University of ArizonaTucson, AZ 85721#Icon ProjectDepartment of Computer ScienceGould-Simpson BuildingThe University of ArizonaTucson, AZ 85721#Icon ProjectDepartment of Computer ScienceGould-Simpson BuildingThe University of ArizonaTucson, AZ 85721#Icon ProjectDepartment of Computer ScienceGould-Simpson BuildingThe University of ArizonaTucson, AZ 85721#Icon ProjectDepartment of Computer ScienceGould-Simpson BuildingThe University of ArizonaTucson, AZ 85721#Icon ProjectDepartment of Computer ScienceGould-Simpson BuildingThe University of ArizonaTucson, AZ 85721#Icon ProjectDepartment of Computer ScienceGould-Simpson BuildingThe University of ArizonaTucson, AZ 85721#Icon ProjectDepartment of Computer ScienceGould-Simpson BuildingThe University of ArizonaTucson, AZ 85721#Icon ProjectDepartment of Computer ScienceGould-Simpson BuildingThe University of ArizonaTucson, AZ 85721#Icon ProjectDepartment of Computer ScienceGould-Simpson BuildingThe University of ArizonaTucson, AZ 85721#Icon ProjectDepartment of Computer ScienceGould-Simpson BuildingThe University of ArizonaTucson, AZ 85721#Icon ProjectDepartment of Computer ScienceGould-Simpson BuildingThe University of ArizonaTucson, AZ 85721#Icon ProjectDepartment of Computer ScienceGould-Simpson BuildingThe University of ArizonaTucson, AZ 85721#Icon ProjectDepartment of Computer ScienceGould-Simpson BuildingThe University of ArizonaTucson, AZ 85721#Icon ProjectDepartment of Computer ScienceGould-Simpson BuildingThe University of ArizonaTucson, AZ 85721#Icon ProjectDepartment of Computer ScienceGould-Simpson BuildingThe University of ArizonaTucson, AZ 85721#Icon ProjectDepartment of Computer ScienceGould-Simpson BuildingThe University of ArizonaTucson, AZ 85721#Icon ProjectDepartment of Computer ScienceGould-Simpson BuildingThe University of ArizonaTucson, AZ 85721 :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldnoci.wrd
anociassociationchronocinematographyCyanocittagenocidalgenocidegymnocidiummonocilatedmonociliamonociliatemonociliatedmonociliceaemonociteNocinociassociationnociceptivenociceptornocifensornociferousnociperceptionnociperceptivenocivenocivousParthenocissusphonocinematographpneumonocirrhosistrypanocidaltrypanocideuranocircitezonociliateNocinenocite :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldpalin.sen
Able was I ere I saw Elbe.A dog! A panic in a pagoda!Ah, Aristides opposed it, sir, aha!Ah, Satan see Natahsa.All erotic, I lose my lyme solicitor, Ella.Al lets Della call Ed, Stella.Analytic Paget saw an inn in a waste-gap city, Lana.A new order began, a more Roman age bred Rowena.Anne, I stay a day at Sienna.Anne, I vote more cars race Rome-to-Vienna.Arden saw I was Nedra.Are we not drawn onwards, we Jews, drawn onward to a new era?Are we not, Rae, near to a new era?A war at Tarawa!A rod, not a bar, a baton, Dora.Ban campus motto, "Bottoms up, MacNab."Bob: "Did Anna peep?" Anna: "Did Bob?"Bog dirt up a sidetrack carted is a putrid gob.Damosel, a poem? A carol? Or a cameo pale? (So mad!)Deer frisk, sir, freed.Degas, are we not drawn onward, we freer few, drawn onward to new eras aged?"Degenerte Moslem, a cad!" Eva saved a camel so Meta reneged.Delia and Edna ailed.Delia sailed as sad Elias ailed.Delia, here we nine were hailed.Delia sailed, Eva waved, Elias ailed.Delis's debonair dehlias, poor, rop, or droop. Sail, Hadrian; Obed sailed.Deliver, Eva, him I have reviled."Deliver desserts," demanded Menesis, "emended, named, stressed, reviled."Dennis, no misfit can act if Simon sinned.Deny me not; atone, my Ned.Desserts I desire not, so long as no lost one rise distressed.Did Dead aid Diana? Ed did.Did Hannah say as Hannah did?Di, did I as I said I did?Did Ione take Kate? No, I did.Did I do, O God, did I as I said I'd do? Good, I did!Did I draw Della too tall, Edward? I did?Doc, note, I dissent. A fast never prevents a fatness. I diet on cod.Dog as a devil deified, lived as a god.DO Goo'S deeds line on? No, Evil's deeds do, O God."Do nine men interprest?" "NIne men," I nod.Do not start at rats to nod.Doom an evil deed, liven a mood.Doom, royal panic, I mimic a play or mood.Dora tendered a net, a rod.Drab as a fool, as aloof as a bard.Drag Reg, no londer bard.Draw -- aye, no melody -- doel-money award.Draw no dray a yard onward.Draw, O Caesar, erase a coward.Draw, O coward!Draw pupil's pup's lip upwardEgad, a base life defiles a bad age.Egad, a base tone denotes a bad age.Egad! Loretta has Adams as mad as a hatter. Old age!Emil asleep, ALlen yodelled "Oy." Nella peels a lime.Emil, asleep, Hannah peels a lime.Enid and Edna dine.Ere hypocrisies or poses are in, my hymn I erase. So prose I, sir, copy here.Esuton saw I was not Sue.Eva, can I pose as Aesop in a cave?Eva, can I stab bats in a cave?Evade me, DavidEve damned Eden, mad Eve.Eve saw diamond, erred, no maid was Eve.Evil is a name of a foeman, as I live.Gate-man sees name, srage-man sees name-tag.God, a red nugget! A fat egg under a dog!Goddesses so pay a possessed dog."Go, droop aloof," sides reversed, is "fool a poor dog."Golf, No, sir, prefer prison flog.Ha! I rush to my lion oily moths, Uriah!Harass selfless Sarah!Harass sensuousness, Sarah.Ha! Robed Selim smiles, Deborah!He lived as a devil, eh?Help Max, Enid -- in example, "H."Here so long? No loser, eh?In airy Sahara's level, Sarah, a Syrian, I.In a regal age ran I.I mode border bard's drowsy swords; drab, ref-robed am I.I maim nine men in Saginaw; wan, I gas nine men in Miami.I maim nine more hero-men in Miami.I, man, am regal; a German am I.I, Marian, I too fall; a foot-in-air am I.I moan, "Live on, O evil Naomi!"I roamed under it as a tired, nude Maori.I saw desserts; I'd no lemons, alas no melon. Distressed was I.I saw thee, madame, eh? 'Twas I.I told Edna how to get a mate: "Go two-handed." Loti."Knight, I ask nary rank," saith gink.Ladle histolytic city lots I held, Al.Lapp, Marc? No, sir, prison-camp pal.Lay a wallaby baby ball away, Al.Leon sees Noel.Lepers repel.Lew, Otto has a hot towel.Live dirt up a sidetrack carted is a putrid evil.Live not on evil.Live not on evil deed, live not on evil.Live on, Time; emit no evil.Live was I ere I saw Evil.Madame, not one man is selfless; I name not one Madam.Madam, I'm Adam.Madam, in Eden I'm -- Adam.Ma is a nun, as I am.Ma is as selfless as I am."Ma," Jerome raps pot top, "spare more jam!"Marge let a moody baby doom a telegram.Marge lets Norah see Sharon's telegram.Marge, let's "went." I await news telegram.Max, I stay awy at six A.M.May a moody baby doom a yam?Milestones? Oh, 'twas I saw those, not Selim.Mirth, sir, a gay asset? No, don't essay a garish trim.Moorgate for nine men in to get a groom.Moors dine, nip -- in Enid's room.Mother at song no star, eh Tom?Mother Eve's noose we soon seve, eh, Tom?Must sell at tallest sum.Name I -- Major-General Clare -- negro Jaime Man.Naomi, did I moan?Name now one man.Ned, go gag Ogden.Ned, I am a maiden.Nella, demand a lad named Allen.Nella risks all: "I will ask Sir Allen."Nella's simple hymn: "I attain my help, Miss Allen."Nella won't set a test now, Allen.Nemo, we revere women.Never a foot too far, even.Niagra, O roar again!No benison, no sin, Ebon.No Dot nor Ottawa, "legal age" law at Toronto, Don.Noel, did I not rub Burton? I did, Leon.Noel, lets egg Estelle on.Noel saw I was Leon.Noel sees Leon.No evil Shahs live on.No, Hal, I led Delilah on.No ham came, sir, no seige is won. Rise, MacMahon.No. I save on final perusal, a sure plan if no evasion.No, is Ivy's order a red rosey vision?No, it can assess an action.No, it's a bar of gold, a bad log for a bastion.No, it is open on one position.No, it is opposed; Art sees Trade's opposition.No, it is opposition.No, it never propagates if I set a "gap" or prevention.No lemons, no melon.No, miss, it is Simon.No Misses orders roses, Simon.No mists or frost, Simon.Nomists reign at Tangier, St. Simon.Nora, alert, saws goldenrod-adorned logs, wastrel Aaron!Norah's foes order red rose of Sharon."Norah's moods," Naomi moans, "doom Sharon."Nor I, fool, ah no? We won halo -- of iron.Nor I nor Emma had level'd a hammer on iron.Norma is as selfless as I am, Ron.No, set a maple here, help a mate, son."Not for Cecil?" asks Alice Crofton.Not I, no hotel, cycle to Honiton."Not New York," Roy went on."Novrad," sides reversed, is "Darvon."No waste, grab a bar, get saw on."Now dine," said I s Enid won.Now do I repay a period won.Now do I report "Sea Moth" to Maestro, period? Won.Now ere we nine were held idle here, we nine were won.Now Eve, we're here, we've won.Now Ned, I am a maiden nun; Ned, I am a maiden won.Now, Ned, I am a maiden won.No word, no bond, row on.Now saw ye no mosses or foam, or aroma of roses. So money was won.Now, sir, a war is won!Nurse, save rare vases, run!Nurse, I spy gypsies, run!Nurse's onset abates, noses run.O gnats, tango!Oh who was it I saw, oh who?On tub, Edward imitated a cadet; a timid raw debut, no?O render gnostic illicit song, red Nero.Paget saw an inn in a waste gap.Pa's a sap.Pat and Edna tap.Peel's lager on red rum did murder no regal sleep."Pooh," smiles Eva, "have Selim's hoop."Poor Dan is in a droop.Pull a bat! I held a ladle, hit a ball up.Pull up, Eva, we're here, wave, pull up.Pull up if I pull up.Pusillanimity obsesses Boy Tim in "All Is Up."Puss, a legacy! Rat in a snug, unsanitary cage, lass, up!"Rats gnash teeth," sang Star.Rats live on evil star.Red now on level -- no wonder.Red Roses run no risk, sir, on nurses order.Red? Rum, eh? 'Twas I saw the murder.Refasten Gipsy's pig-net safer.Regard a mere mad rager.Reg, no lone car won, now race no longer.Red root put up to order.Remit Rome cargo to go to Grace Mortimer.Repel evil as a live leper.Resume so pacific a pose, muser.Retracting, I sign it, Carter.Revenge my baby, meg? Never!Revered now I live on. O did I do no evil, I wonder ever?"Reviled did I live," said I, "as evil I did deliver.""Revolt, love!" raved Eva. "Revolt, lover!"Revolt on Yale, Democrats edit "Noon-Tide Star." Come, delay not lover.Rise, morning is red, no wonder-sign in Rome, Sir.Rise to vote, Sir.Ron, Eton mistress asserts I'm no tenor.Roy Ames, I was a wise mayor.Roy, am I mayor?Sail on, game vassal! Lacy callas save magnolias!Saladin enrobes a baroness, Senora, base-born Enid, alas.Salisbury moor, sir, is roomy. Rub Silas."Sal is not in?" Ruth asks. "Ah, turn it on, Silas."See few owe fees.See, slave, I demonstrate yet arts no medieval sees.Selim's tired, no wonder, it's miles.Semite, be sure! Damn a man-made ruse betimes.Set a broom on no moor, Bates.Sh! Tom sees moths.Sir, I demand, I am a maid named Iris.Sir, I'm Iris.Sir, I soon saw Bob was no Osiris."Sirrah! Deliver deified desserts detartrated!" stressed defied, reviled Harris.Sis, Sargasso moss a grass is.Sit on a potato pan, Otis.Si, we'll let Dad tell Lewis.Six at party, no pony-trap, taxis."Slang is not suet, is it?" Euston signals.Slap-dab set-up, Mistress Ann asserts, imputes bad pals.Snug Satraps eye Sparta's guns."So I darn on," a Canon radios.So may Apollo pay Amos.So may get Arts award. Draw a strategy, Amos.So may Obadiah aid a boy, Amos.So may Obadiah, even in Nineveh, aid a boy, Amos.Some men interpret nine memos.So remain a mere man. I am Eros.Sore was I ere I saw Eros.Star? Come, Donna Melba, I'm an amiable man -- no Democrats!Stella won no wallets.St. Eloi, venin saved a mad Eva's nine violets.Stephen, my hat! Ah, what a hymn, eh, pets?Step on hose-pipes? Oh no, pets.Step on no pets!Stop! Murder us not tonsured rumpots!"Stop!" nine myriad murmur. "Put up rum, dairmen, in pots."Stop, Syrian, I see bees in airy spots.Stop, Syrian, I start at rats in airy spots.St. Simon sees no mists.Straw? No, too stupid a fad. I put soot on warts.Sue, dice, do, to decide us."Sue," Tom smiles, "Selim smote us.""Suit no regrets." A motto, Master Gerontius.Sums are not set as a test on Erasmus.Telegram, Margelet!Ten animals I slam in a net.Ten dip a rapid net.Tenet C is a basis, a basic tenet.Tennis set won now Tess in net.Ten? No bass orchestra tarts, eh? Cross a bonnet!Tense, I snap Sharon roses, or Norah's pansies net.Tessa's in Italy, Latin is asset.Tide-net safe, soon, Allin. A manilla noose fastened it.'Tis Ivan on a visit.To nets, ah, no, son, haste not.Too bad, I hid a boot.Too far away, no mere clay or royal ceremony, a war afoot.Too far, Edna, wonder afoot.Too hot to hoot.Top step -- Sara's pet spot.Top step's pup's pet spot.Tracy, no panic in a pony-cart.Trade ye no mere moneyed art.Trap a rat! Stare, piper, at Star apart.War-distended nets I draw."Warden in a Cap," Mac's pup scamp, a canine draw.Ward nurses run "draw."Was it a rat I saw?Was it felt? I had a hit left, I saw.Was raw tap ale not a reviver at one lap at Warsaw?We'll let Dad tell Lew.We seven, Eve, sew.Wonders in Italy, Latin is "Red" now.Won race, so loth to lose car now.Won't I repaper? Repaper it now.Won't lovers revolt now?Yawn a more Roman way.Yes, Mark, cable to hotel, "Back Ramsey."Yes, Syd, Owen saved Eva's new Odyssey.Yo! Bottoms up, U.S. Motto, boy!Zeus was deified, saw Suez.Dior Droid.Sex at noon taxes.Solo gigolos.Senile felines.Tuna nut. :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldpalin.wrd
AaaaabaaccaaddaaffaagaahaajajaakaalaalalaalulaamaammaanaananaannaapaaraararaattaavaawaBbbibbobboobbubCccivicDddaddeeddeedeeddeggeddiddoddudEeekeelleemeereeveeweeyeFfGggaggiggogHhhahhallahhuhIiihiimiimmiJjKkkakkakkayakkeekkelekLllemellevelMmmaammadammemmesemmimminimmummurdrumNnnannonnoonnunOoohoottoPppappeeppeppippooppoppupQqRrradarredderreferrepaperretterreverreviverrotatorrotorSssirississooloosTttattebbetteettenetterrettittoottottsttuttytUuuluululuumuutuVvWwwawwowXxYyyarayyoyZz :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldpoe.txt
On the Future!-how it tells Of the rapture that impells To the swinging and the ringing Of the bells, bells, bells- Of the bells, bells, bells, bells, Bells, bells, bells- To the rhyming and the chiming of the bells! :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldpoem.rsg
Let us pass to the secondary evolution considered in itself. Itinvolves two great features, -- differentiation and the increase ofdefiniteness through segregation. The differentiation is a cumulativeprocess, due to the fact that a plastic body keeps the traces of whathas happened to it, and so constantly prepares a basis for newvarieties of effects to be produced upon its various parts.The segregation is due to the sorting types of forces, such aswere exemplified in our summary. :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldvowel.wrd
abietineousabstemiousabstemiouslyabstemiousnessabstentiousacetabuliferousacetariousacheilousacheirousacleistousactinopterygiousadenocarcinomatousadvectitiousadventitiousadventitiouslyadventitiousnessadversariousadversifoliousaecioteliumaegithognathousaeriferousaerobioeritoneumaerophilousaeruginousaffectiousalternipetalousalternisepalousamberiferousamentiferousametoeciousampelidaceousampelideousanaerobiousandrodioeciousandromonoeciousanemophilousanepigraphousannelidousantenniferousantheriferousanthraceniferousantireligiousaploperistomatousappendiciousappenditiousappetitiousaqueoigneousarchicleistogamousarenariousarenicolousargentiferousargilloferruginousargumentatiousarietinousarmeniaceousarreptitiousarseniferousarseniousarteriopalmusarteriousarteriovenousasclepiadaceousasclepiadeousasperifoliousassentatiousathericerousauteciousauteciouslyauteciousnessautoeciousautoeciouslyautoeciousnessbacteriaceousbacterioagglutininbacteriofluorescinbacteriogenousbacteriophagousbacteriopurpurinbacteriotherapeuticbacteriouscaesalpiniaceouscaesiouscalcareoargillaceouscalcareobituminouscalcareosiliceouscavernicolousceratopteridaceouschaetiferousChamaesiphonaceouschlamydobacteriaceousdesmarestiaceousdiapensiaceouseflagelliferousfacetiousfacetiouslyfacetiousnessfilamentiferousflagellariaceousflagelliferousfracedinousfragmentitiousfrankeniaceousgarnetiferoushamamelidaceoushaploperistomoushexapetaloideoushypocraterimorphouskrameriaceouslaboulbeniaceouslaemodipodouslamellicornouslamelliferousLapeirousialateriflorouslaterifoliouslateritiousmacrolepidopterousmagnetiferousmajestiousmalacopterygiousmalesherbiaceousmalleiferousmetarseniousmyxobacteriaceousnonabstemiousnonadventitiousnonargentiferousnonfacetiousoverabstemiousoverabstemiousnesspalaeodictyopterouspancreaticoduodenalpancreaticoduodenostomyparallelinervousparallepipedousparmeliaceousparoeciousparoeciouslyparoeciousnessplacentiferousplacentigerouspolygamodioeciouspseudosacrilegiouspyroarseniousquadragenariousquadrigeminousquadrigenariousracemiferousrafflesiaceousramentiferoussacrilegioussacrilegiouslysacrilegiousnesssanguineobilioussaprolegniaceoussaprolegnioussarmentiferoussarraceniaceoussatellitioussphacelariaceoussphaeriaceoussquamelliferousstapediovestibularsulpharsenioussulphoarsenioussupracensorioustaeniosomousthioarsenioustrajectitiousultraceremoniousultraconscientiousultraexpeditiousultraingeniousultrareligiousunfacetiousunsacrilegiousvalerianaceousvallisneriaceousvaucheriaceous :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldz1.lin
0->1[0]1[0]01->11[->[]->]0:5 :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldz2.lin
0->1[0]1[0]01->110:5 :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldz3.lin
a->ab->abc->abbcac:8 :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldz4.lin
1->2#33->2#44->5045->66->77->8(1)1:14 :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldprocs:allof.icn
############################################################################## Name: allof.icn## Title: Iterative Conjunction Control Operation## Author: Robert J. Alexander## Date: November 3, 1989############################################################################### allof{expr1,expr2} -- Control operation that performs iterative# conjunction.## Expr1 works like the control expression of "every-do"; it controls# iteration by being resumed to produce all of its possible results.# The allof{} expression produces the outcome of conjunction of all# of the resulting expr2s, one instance of expr2 created for each# iteration.## For example:## global c# ...# pattern := "ab*"# "abcdef" ? {# allof { c := !pattern ,# if c == "*" then move(0 to *&subject - &pos + 1) else =c# } & pos(0)# }## This example will perform a wild card match on "abcdef" against# pattern "ab*", where "*" in a pattern matches 0 or more characters.# Since pos(0) will fail the first time it is evaluated, the allof{}# expression will be resumed just as a conjunction expression would,# and backtracking will propagate through all of the expr2s; the# expression will ultimately succeed (as its conjunctive equivalent# would).## Note that, due to the scope of variables in co-expressions,# communication between expr1 and expr2 must be via global variables,# hence c in the above example must be global.## The allof{} procedure models Icon's expression evaluation# mechanism in that it explicitly performs backtracking. The author of# this procedure knows of no way to use Icon's built-in goal directed# evaluation to perform conjunction of a arbitrary number of computed# expressions (suggestions welcome).############################################################################### Requires: co-expressions#############################################################################procedure allof(expr) local elist,i,x,v # # Initialize # elist := [] # expression list i := 1 # expression list pointer # # Loop until backtracking over all expr[2]s has failed. # while i > 0 do { if not (x := elist[i]) then # # If we're at the end of the list of expressions, attempt an # iteration to produce another expression. # if @expr[1] then put(elist,x := ^expr[2]) else { # # If no further iterations, suspend a result. # suspend v # # We've been backed into -- back up to last expr[2]. # i -:= 1 } # # Evaluate the expression. # if v := @x then { # # If success, move on to the refreshed next expression. # i +:= 1 elist[i] := ^elist[i] } else # # If failure, back up. # i -:= 1 }end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldbincvt.icn
############################################################################## Name: bincvt.icn## Title: Convert binary data## Author: Robert J. Alexander## Date: December 5, 1989############################################################################### unsigned() -- Converts binary byte string into unsigned integer.# Detects overflow if number is too large.## This procedure is normally used for processing of binary data# read from a file.### raw() -- Puts raw bits of characters of string s into an integer. If# the size of s is less than the size of an integer, the bytes are put# into the low order part of the integer, with the remaining high order# bytes filled with zero. If the string is too large, the most# significant bytes will be lost -- no overflow detection.## This procedure is normally used for processing of binary data# read from a file.### rawstring() -- Creates a string consisting of the raw bits in the low# order "size" bytes of integer i.## This procedure is normally used for processing of binary data# to be written to a file.#############################################################################procedure unsigned(s) local i i := 0 every i := ord(!s) + i * 256 return iendprocedure raw(s) local i i := 0 every i := ior(ord(!s),ishift(i,8)) return iendprocedure rawstring(i,size) local s s := "" every 1 to size do { s := char(iand(i,16rFF)) || s i := ishift(i,-8) } return send :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldbold.icn
############################################################################## Name: bold.icn## Title: Procedures for enboldening and underscoring test## Author: Ralph E. Griswold## Date: June 10, 1988############################################################################## # These procedures produce text with interspersed characters suit-# able for printing to produce the effect of boldface (by over-# striking) and underscoring (using backspaces).# # bold(s) bold version of s# # uscore(s) underscored version of s# ############################################################################procedure bold(s) local c static labels, trans, max initial { labels := "1" trans := repl("1\b",4) || "1" max := *labels trans := bold(string(&lcase)) labels := string(&lcase) max := *labels } if *s <= max then return map(left(trans,9 * *s),left(labels,*s),s) else return bold(left(s,*s - max)) || map(trans,labels,right(s,max))endprocedure uscore(s) static labels, trans, max initial { labels := "1" trans := "_\b1" max := *labels trans := uscore(string(&lcase)) labels := string(&lcase) max := *labels } if *s <= max then return map(left(trans,3 * *s),left(labels,*s),s) else return uscore(left(s,*s - max)) || map(trans,labels,right(s,max))end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldcodeobj.icn
############################################################################## Name: codeobj.icn## Title: Procedures to encode and decode Icon data## Author: Ralph E. Griswold## Date: November 16, 1988############################################################################### These procedures provide a way of storing Icon values as strings and# retrieving them. The procedure encode(x) converts x to a string s that# can be converted back to x by decode(s). These procedures handle all# kinds of values, including structures of arbitrary complexity and even# loops. For "scalar" types -- null, integer, real, cset, and string --## decode(encode(x)) === x## For structures types -- list, set, table, and record types --# decode(encode(x)) is, for course, not identical to x, but it has the# same "shape" and its elements bear the same relation to the original# as if they were encoded and decode individually.## No much can be done with files, functions and procedures, and# co-expressions except to preserve type and identification.## The encoding of strings and csets handles all characters in a way# that it is safe to write the encoding to a file and read it back.## No particular effort was made to use an encoding of value that# minimizes the length of the resulting string. Note, however, that# as of Version 7 of Icon, there are no limits on the length of strings# that can be written out or read in.############################################################################### The encoding of a value consists of four parts: a tag, a length,# a type code, and a string of the specified length that encodes the value# itself.## The tag is omitted for scalar values that are self-defining.# For other values, the tag serves as a unique identification. If such a# value appears more than once, only its tag appears after the first encoding.# There is, therefore, a type code that distinguishes a label for a previously# encoded value from other encodings. Tags are strings of lowercase# letters. Since the tag is followed by a digit that starts the length, the# two can be distinguished.## The length is simply the length of the encoded value that follows.## The type codes consist of single letters taken from the first character# of the type name, with lower- and uppercase used to avoid ambiguities.## Where a structure contains several elements, the encodings of the# elements are concatenated. Note that the form of the encoding contains# the information needed to separate consecutive elements.## Here are some examples of values and their encodings:## x encode(x)# -------------------------------------------------------## 1 "1i1"# 2.0 "3r2.0"# &null "0n"# "\377" "4s\\377"# '\376\377' "8c\\376\\377"# procedure main "a4pmain"# co-expression #1 (0) "b0C"# [] "c0L"# set() "d0S"# table("a") "e3T1sa"# L1 := ["hi","there"] "f11L2shi5sthere"## A loop is illsutrated by## L2 := []# put(L2,L2)## for which## x encode(x)# -------------------------------------------------------## L2 "g3L1lg"## Of course, you don't have to know all this to use encode and decode.############################################################################### Links: escape, gener## Requires: co-expressions## See also: object.icn#############################################################################link escape, generglobal outlab, inlabrecord triple(type,value,tag)# Encode an arbitary value as a string.#procedure encode(x,level) local str, tag, Type static label initial label := create "l" || star(string(&lcase)) if /level then outlab := table() # table is global, but reset at # each root call. tag := "" Type := typecode(x) if Type == !"ri" then str := string(x) # first the scalars else if Type == !"cs" then str := image(string(x))[2:-1] # remove quotes else if Type == "n" then str := "" else if Type == !"LSRTfpC" then # next the structures and other types if str := \outlab[x] then # if the object has been processed, Type := "l" # use its label and type it as label. else { tag := outlab[x] := @label # else make a label for it. str := "" if Type == !"LSRT" then { # structures every str ||:= encode( # generate, recurse, and concatenate case Type of { !"LS": !x # elements "T": x[[]] | !sort(x,3) # default, then elements "R": type(x) | !x # type then elements } ,1) # indicate internal call } else str ||:= case Type of { # other things "f": image(x) "C": "" "p": image(x) ? { # watch out for record constructors tab(find("record constructor ") + *"record constructor ") | tab(upto(' ') + 1) tab(0) } } } else stop("unsupported type in encode: ",image(x)) return tag || *str || Type || strend# Produce a one-letter code for the type.#procedure typecode(x) local code # be careful of records and their constructors if image(x) ? ="record constructor " then return "p" if image(x) ? ="record" then return "R" code := type(x) if code == ("list" | "set" | "table" | "co-expression") then code := map(code,&lcase,&ucase) return code[1]end# Generate decoded results. At the top level, there is only one,# but for structures, it is called recursively and generates the# the decoded elements. #procedure decode(s,level) local p if /level then inlab := table() # global but reset every p := separ(s) do { suspend case p.type of { "l": inlab[p.value] # label for an object "i": integer(p.value) "s": escape(p.value) "c": cset(escape(p.value)) "r": real(p.value) "n": &null "L": delist(p.value,p.tag) "R": derecord(p.value,p.tag) "S": deset(p.value,p.tag) "T": detable(p.value,p.tag) "f": defile(p.value) "C": create &fail # can't hurt much to fail "p": (proc(p.value) | stop("encoded procedure not found")) \ 1 default: stop("unexpected type in decode: ",p.type) } }end# Generate triples for the encoded values in concatenation.#procedure separ(s) local p, size while *s ~= 0 do { p := triple() s ?:= { p.tag := tab(many(&lcase)) size := tab(many(&digits)) | break p.type := move(1) p.value := move(size) tab(0) } suspend p }end# Decode a list. The newly constructed list is added to the table that# relates tags to structure values.#procedure delist(s,tag) local a inlab[tag] := a := [] # insert object for label every put(a,decode(s,1)) return aend# Decode a set. Compare to delist above.#procedure deset(s,tag) local S inlab[tag] := S := set() every insert(S,decode(s,1)) return Send# Decode a record.#procedure derecord(s,tag) local R, e e := create decode(s,1) # note use of co-expressions to control # generation, since record must be constructed # before fields are produced. inlab[tag] := R := proc(@e)() | stop("error in decoding record") every !R := @e return Rend# Decode a table.#procedure detable(s,tag) local t, e e := create decode(s,1) # see derecord above; here it's the default # value that motivates co-expressions. inlab[tag] := t := table(@e) while t[@e] := @e return tend# Decode a file.#procedure defile(s) s := decode(s,1) # the result is an image of the original file. return case s of { # files aren't so simple ... "&input": &input "&output": &output "&errout": &errout default: s ? { ="file(" # open for reading to play it safe open(tab(upto(')'))) | stop("cannot open encoded file") } }end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldcollate.icn
############################################################################## Name: collate.icn## Title: Collate and decollate strings## Author: Ralph E. Griswold## Date: June 10, 1988############################################################################## # These procedures collate (interleave) respective characters of# two strings and decollate such strings by selecting every other# character of a string. produce a string consisting of inter-# leaved characters of s1 and s2.# # collate(s1,s2) collate the characters of s1 and s2. For# example,## collate("abc","def")## produces "adbecf".# # decollate(s,i) produce a string consisting of every other# character of s. If i is odd, the odd-numbered# characters are selected, while if i is even,# the even-numbered characters are selected.# ############################################################################procedure collate(s1,s2) local length, ltemp, rtemp static llabels, rlabels, clabels, blabels, half initial { llabels := "ab" rlabels := "cd" blabels := llabels || rlabels clabels := "acbd" half := 2 ltemp := left(&cset,*&cset / 2) rtemp := right(&cset,*&cset / 2) clabels := collate(ltemp,rtemp) llabels := ltemp rlabels := rtemp blabels := string(&cset) half := *llabels } length := *s1 if length <= half then return map(left(clabels,2 * length),left(llabels,length) || left(rlabels,length),s1 || s2) else return map(clabels,blabels,left(s1,half) || left(s2,half)) || collate(right(s1,length - half),right(s2,length - half))end# decollate s according to even or odd i#procedure decollate(s,i) static dsize, image, object local ssize initial { image := collate(left(&cset,*&cset / 2),left(&cset,*&cset / 2)) object := left(&cset,*&cset / 2) dsize := *image } i %:= 2 ssize := *s if ssize + i <= dsize then return map(object[1+:(ssize + i) / 2],image[(i + 1)+:ssize],s) else return map(object[1+:(dsize - 2) / 2],image[(i + 1)+:dsize - 2], s[1+:(dsize - 2)]) || decollate(s[dsize - 1:0],i)end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldcolmize.icn
############################################################################## Name: colmize.icn## Title: Arrange data into columns## Author: Robert J. Alexander## Date: December 5, 1989############################################################################### colmize() -- Arrange data into columns.## Procedure to arrange a number of data items into multiple columns.# Items are arranged in column-wise order, that is, the sequence runs# down the first column, then down the second, etc.## This procedure goes to great lengths to print the items in as few# vertical lines as possible.#############################################################################procedure colmize(entries,maxcols,space,minwidth,rowwise,distribute) local mean,cols,lines,width,i,x,wid,extra,t,j # # Process arguments -- provide defaults. # # entries: a list of items to be columnized /maxcols := 80 # max width of output lines /space := 2 # min nbr of spaces between columns /minwidth := 0 # min column width # rowwise: if nonnull, entries are listed in rowwise order rather than # columnwise # # Starting with a trial number-of-columns that is guaranteed # to be too wide, successively reduce the number until the # items can be packed into the allotted width. # mean := 0 every mean +:= *!entries mean := mean / (0 ~= *entries) | 1 every cols := (maxcols + space) * 2 / (mean + space) to 1 by -1 do { lines := (*entries + cols - 1) / cols width := list(cols,minwidth) i := 0 if /rowwise then { # if column-wise every x := !entries do { width[i / lines + 1] <:= *x + space i +:= 1 } } else { # else row-wise every x := !entries do { width[i % cols + 1] <:= *x + space i +:= 1 } } wid := 0 every x := !width do wid +:= x if wid <= maxcols + space then break } # # Now output the data in columns. # extra := (\distribute & (maxcols - wid) / (0 < cols - 1)) | 0 if /rowwise then { # if column-wise every i := 1 to lines do { t := "" every j := 0 to cols - 1 do t ||:= left(entries[i + j * lines],width[j + 1] + extra) suspend trim(t) } } else { # else row-wise every i := 0 to lines - 1 do { t := "" every j := 1 to cols do t ||:= left(entries[j + i * cols],width[j] + extra) suspend trim(t) } }end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldcomplex.icn
############################################################################## Name: complex.icn## Title: Perform complex arithmetic## Author: Ralph E. Griswold## Date: June 10, 1988############################################################################## # The following procedures perform operations on complex numbers.# # complex(r,i) create complex number with real part r and# imaginary part i# # cpxadd(x1,x2) add complex numbers x1 and x2# # cpxdiv(x1,x2) divide complex number x1 by complex number x2# # cpxmul(x1,x2) multiply complex number x1 by complex number# x2# # cpxsub(x1,x2) subtract complex number x2 from complex# number x1# # cpxstr(x) convert complex number x to string represen-# tation# # strcpx(s) convert string representation s of complex# number to complex number# ############################################################################record complex(rpart,ipart)procedure strcpx(s) local i i := upto('+-',s,2) return complex(+s[1:i],+s[i:-1])endprocedure cpxstr(x) if x.ipart < 0 then return x.rpart || x.ipart || "i" else return x.rpart || "+" || x.ipart || "i"endprocedure cpxadd(x1,x2) return complex(x1.rpart + x2.rpart,x1.ipart + x2.ipart)endprocedure cpxsub(x1,x2) return complex(x1.rpart - x2.rpart,x1.ipart - x2.ipart)endprocedure cpxmul(x1,x2) return complex(x1.rpart * x2.rpart - x1.ipart * x2.ipart, x1.rpart * x2.ipart + x1.ipart * x2.rpart)endprocedure cpxdiv(x1,x2) local denom denom := x2.rpart ^ 2 + x2.ipart ^ 2 return complex((x1.rpart * x2.rpart + x1.ipart * x2.ipart) / denom,(x1.ipart * x2.rpart - x1.rpart * x2.ipart) / denom)end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldcurrency.icn
############################################################################## Name: currency.icn## Title: Currency formatting procedure## Author: Robert J. Alexander## Date: December 5, 1989############################################################################### currency() -- Formats "amount" in standard American currency format.# "amount" can be a real, integer, or numeric string. "width" is the# output field width, in which the amount is right adjusted. The# returned string will be longer than "width" if necessary to preserve# significance. "minus" is the character string to be used for# negative amounts (default "-"), and is placed to the right of the# amount.#############################################################################procedure currency(amount,width,minus) local sign,p /width := 0 /minus := "-" amount := real(amount) | fail if amount < 0 then { sign := minus amount := -amount } else sign := repl(" ",*minus) amount := string(amount) amount := if p := find(".",amount) then left(amount,p + 2,"0") else amount || ".00" if match("0.",amount) then amount[1:3] := "0." amount := "$" || amount || sign return if *amount >= width then amount else right(amount,width)end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Folddif.icn
############################################################################## Name: dif.icn## Title: Diff engine## Author: Robert J. Alexander## Date: May 15, 1989############################################################################### The procedure dif() is a generator that produces a sequence of# differences between an arbitrary number of input streams. Each result# is returned as a list of diff_recs, one for each input stream, with# each diff_rec containing a list of items that differ and their position# in the input stream. The diff_rec type is declared as:## record diff_rec(pos,diffs)## Dif fails if there are no differences, i.e. it produces an empty# result sequence.## For example, if two input streams are:## a b c d e f g h# a b d e f i j## the output sequence would be:## [diff_rec(3,[c]),diff_rec(3,[])]# [diff_rec(7,[gh]),diff_rec(6,[i,j])## The arguments to dif() are:## stream A list of data objects that represent input streams# from which dif will extract its input "records".# The elements can be of several different types which# result in different actions, as follows:## Type Action# =========== =============================# file file is "read" to get records## co-expression co-expression is activated to# get records## list records are "gotten" (get()) from# the list## diff_proc a record type defined in "dif" to# allow a procedure (or procedures)# suppled by dif's caller to be called# to get records. Diff_proc has two# fields, the procedure to call and the# argument to call it with. Its# definition looks like this:## record diff_proc(proc,arg)# ## Optional arguments:## compare Item comparison procedure -- succeeds if# "equal", otherwise fails (default is the# identity "===" comparison). The comparison# must allow for the fact that the eof object# (see next) might be an argument, and a pair of# eofs must compare equal.# eof An object that is distinguishable from other# objects in the stream. Default is &null.# group A procedure that is called with the current number# of unmatched items as its argument. It must# return the number of matching items required# for file synchronization to occur. Default is# the formula Trunc((2.0 * Log(M)) + 2.0) where# M is the number of unmatched items.#############################################################################record diff_rec(pos,diffs)record diff_proc(proc,arg)record diff_file(stream,queue)procedure dif(stream,compare,eof,group) local f,linenbr,line,difflist,gf,i,j,k,l,m,n,x,test, result,synclist,nsyncs,syncpoint /compare := proc("===",2); /group := groupfactor f := []; every put(f,diff_file(!stream,[])) linenbr := list(*stream,0); line := list(*stream); test := list(*stream) difflist := list(*stream); every !difflist := [] repeat { repeat { every i := 1 to *stream do line[i] := diffread(f[i]) | eof if not (every x := !line do (x === eof) | break) then break break every !linenbr +:= 1 if (every x := !line[2:0] do compare(x,line[1]) | break) then break } every i := 1 to *stream do difflist[i] := [line[i]] repeat { every i := 1 to *stream do put(difflist[i],diffread(f[i]) | eof) gf := group(*difflist[1]) every i := 1 to *stream do testifflist[i][-gf:0] j := *difflist[1] - gf + 1 synclist := list(*stream); every !synclist := list(*stream) every k := 1 to *stream do synclist[k][k] := j nsyncs := list(*stream,1) every i := 1 to j do { # position to look at every k := 1 to *stream do { # stream whose new stuff to compare every l := 1 to *stream do { # streams comparing to at pos i if /synclist[k][l] then { m := i - 1 if not every n := 1 to gf do { if not compare(test[k][n],difflist[l][m +:= 1]) then break } then { synclist[k][l] := i if (nsyncs[k] +:= 1) = *stream then break break break break } } } } } } synclist := synclist[k]; result := list(*stream) every i := 1 to *stream do { j := synclist[i]; while difflist[i][j -:= 1] === eof result[i] := diff_rec(linenbr[i],difflist[i][1:j + 1]) f[i].queue := difflist[i][synclist[i] + gf:0] ||| f[i].queue linenbr[i] +:= synclist[i] + gf - 2 difflist[i] := [] } suspend result }endprocedure diffread(f) local x return get(f.queue) | case type(x := f.stream) of { "file": read(x) "co-expression": @x "diff_proc": x.proc(x.arg) "list": get(x) }endprocedure groupfactor(m) # Compute: Trunc((2.0 * Log(m)) + 2.0) m := string(m) return 2 * *m + if m <<= "316227766"[1+:*m] then 0 else 1end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldescape.icn
############################################################################## Name: escape.icn## Title: Interpret Icon literal escapes## Author: William H. Mitchell, modified by Ralph E. Griswold## Date: November 21, 1988############################################################################## # The procedure escape(s) produces a string in which Icon quoted# literal escape conventions in s are replaced by the corresponding# characters. For example, escape("\\143\\141\\164") produces the# string "cat".# ############################################################################procedure escape(s) local ns, c ns := "" s ? { while ns ||:= tab(upto('\\')) do { move(1) ns ||:= case c := move(1 | 0) of { "b": "\b" "d": "\d" "e": "\e" "f": "\f" "l": "\n" "n": "\n" "r": "\r" "t": "\t" "v": "\v" "'": "'" "\"": "\"" "x": hexcode() "^": ctrlcode() !"01234567": octcode() default: c } } ns ||:= tab(0) } return nsendprocedure hexcode() local i, s static cdigs initial cdigs := ~'0123456789ABCDEFabcdef' move(i := 2 | 1) ? s := tab(upto(cdigs) | 0) move(*s - i) return char("16r" || s)endprocedure octcode() local i, s static cdigs initial cdigs := ~'01234567' move(-1) move(i := 3 | 2 | 1) ? s := tab(upto(cdigs) | 0) move(*s - i) return char("8r" || s)endprocedure ctrlcode(s) return char(upto(map(move(1)),&lcase))end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldfilename.icn
############################################################################## Name: filename.icn## Title: Parse file names## Author: Robert J. Alexander## Date: December 5, 1989############################################################################### suffix() -- Parses a hierarchical file name, returning a 2-element# list: [prefix,suffix]. E.g. suffix("/a/b/c.d") -> ["/a/b/c","d"]### tail() -- Parses a hierarchical file name, returning a 2-element# list: [head,tail]. E.g. tail("/a/b/c.d") -> ["/a/b","c.d"].## components() -- Parses a hierarchical file name, returning a list of# all directory names in the file path, with the file name (tail) as# the last element.## E.g. components("/a/b/c.d") -> ["/","a","b","c.d"].#############################################################################procedure suffix(s,separator) local i /separator := "." i := *s + 1 every i := find(separator,s) return [s[1:i],s[(*s >= i) + 1:0] | &null]endprocedure tail(s,separator) local i /separator := "/" i := 0 every i := find(separator,s) return [s[1:i + (i <= 1 | 0)],"" ~== s[i + 1:0] | &null]endprocedure components(s,separator) local x,head /separator := "/" x := tail(s,separator) return case head := x[1] of { separator: [separator] "": [] default: components(head) } ||| ([&null ~=== x[2]] | [])end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldfullimag.icn
############################################################################## Name: fullimage.icn## Title: Produces complete image of structured data## Author: Robert J. Alexander## Date: December 5, 1989############################################################################### fullimage() -- enhanced image()-type procedure that outputs all data# contained in structured types. The "level" argument tells it how far# to descend into nested structures (defaults to unlimited).#############################################################################global fullimage_level,fullimage_maxlevel,fullimage_done,fullimage_used, fullimage_indentprocedure fullimage(x,indent,maxlevel) local tr,s,t # # Initialize # tr := &trace ; &trace := 0 # turn off trace till we're done fullimage_level := 1 fullimage_indent := indent fullimage_maxlevel := \maxlevel | 0 fullimage_done := table() fullimage_used := set() # # Call fullimage_() to do the work. # s := fullimage_(x) # # Remove unreferenced tags from the result string, and even # renumber them. # fullimage_done := table() s ? { s := "" while s ||:= tab(upto('\'"<')) do { case t := move(1) of { "\"" | "'": { s ||:= t while (s ||:= tab(find(t) + 1)) \ 1 & s[-2] ~== "\\" } "<": { t := +tab(find(">")) & move(1) if member(fullimage_used,t) then { /fullimage_done[t] := *fullimage_done + 1 s ||:= "<" || fullimage_done[t] || ">" } } } } s ||:= tab(0) } # # Clean up and return. # fullimage_done := fullimage_used := &null # remove structures &trace := tr # restore &trace return sendprocedure fullimage_(x,noindent) local s,t,tr t := type(x) s := case t of { "null" | "string" | "integer" | "real" | "co-expression" | "cset" | "file" | "procedure" | "external": image(x) default: fullimage_structure(x) } # # Return the result. # return ( if \fullimage_indent & not \noindent then "\n" || repl(fullimage_indent,fullimage_level - 1) || s else s )endprocedure fullimage_structure(x) local sep,s,t,tag,y # # If this structure has already been output, just output its tag. # if \(tag := fullimage_done[x]) then { insert(fullimage_used,tag) return "<" || tag || ">" } # # If we've reached the max level, just output a normal image # enclosed in braces to indicate end of the line. # if fullimage_level = fullimage_maxlevel then return "{" || image(x) || "}" # # Output the structure in a style indicative of its type. # fullimage_level +:= 1 fullimage_done[x] := tag := *fullimage_done + 1 if (t := type(x)) == ("table" | "set") then x := sort(x) s := "<" || tag || ">" || if t == "list" then "[" else t || "(" sep := "" if t == "table" then every y := !x do { s ||:= sep || fullimage_(y[1]) || "->" || fullimage_(y[2],"noindent") sep := "," } else every s ||:= sep || fullimage_(!x) do sep := "," fullimage_level -:= 1 return s || if t == "list" then "]" else ")"end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldgcd.icn
############################################################################## Name: gcd.icn## Title: Compute greatest cmmon denominator## Author: Ralph E. Griswold## Date: May 11, 1989############################################################################### This procedure computes the greatest common denominator of two# integers. If both are zero, it fails.#############################################################################procedure gcd(i,j) local r if i = j = 0 then fail if i = 0 then return j if j = 0 then return i i := abs(i) j := abs(j) repeat { r := i % j if r = 0 then return j i := j j := r }end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldgener.icn
############################################################################## Name: gener.icn## Title: Generate miscellaneous sequences## Author: Ralph E. Griswold## Date: June 10, 1988############################################################################## # These procedures generate sequences of results.# # hex() sequence of hexadecimal codes for numbers# from 0 to 255# # label(s,i) sequence of labels with prefix s starting at# i# # octal() sequence of octal codes for numbers from 0 to# 255# # star(s) sequence consisting of the closure of s# starting with the empty string and continuing# in lexical order as given in s# ############################################################################procedure hex() suspend !"0123456789abcdef" || !"0123456789abcdef"endprocedure label(s,i) suspend s || (i | (i +:= |1))endprocedure octal() suspend (0 to 3) || (0 to 7) || (0 to 7)endprocedure star(s) suspend "" | (star(s) || !s)end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldhexcvt.icn
############################################################################## Name: hexcvt.icn## Title: Hexadecimal conversion## Author: Robert J. Alexander## Date: December 5, 1989############################################################################### hex() -- Converts string of hex digits into an integer.### hexstring() -- Returns a string that is the hexadecimal# representation of the argument.#############################################################################procedure hex(s) local a,c a := 0 every c := !map(s) do a := ior(find(c,"0123456789abcdef") - 1,ishift(a,4)) | fail return aendprocedure hexstring(i) local s i := integer(i) | fail if i = 0 then s := "0" else { s := "" while i ~= 0 do { s := "0123456789ABCDEF"[iand(i,15) + 1] || s i := ishift(i,-4) } } s := right(s,\n,"0") return send :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldimage.icn
############################################################################## Name: image.icn## Title: Produce generalized image of Icon value## Author: Michael Glass, Ralph E. Griswold, and David Yost## Date: June 10, 1988############################################################################## # The procedure Image(x,style) produces a string image of the value x.# The value produced is a generalization of the value produced by# the Icon function image(x), providing detailed information about# structures. The value of style determines the formatting and# order of processing:## 1 indented, with ] and ) at end of last item (default)# 2 indented, with ] and ) on new line# 3 puts the whole image on one line# 4 as 3, but with structures expanded breadth-first instead of# depth-first as for other styles.# ############################################################################## Tags are used to uniquely identify structures. A tag consists# of a letter identifying the type followed by an integer. The tag# letters are L for lists, R for records, S for sets, and T for# tables. The first time a structure is encountered, it is imaged# as the tag followed by a colon, followed by a representation of# the structure. If the same structure is encountered again, only# the tag is given.# # An example is# # a := ["x"]# push(a,a)# t := table()# push(a,t)# t[a] := t# t["x"] := []# t[t] := a# write(Image(t))# # which produces# # T1:[# "x"->L1:[],# L2:[# T1,# L2,# "x"]->T1,# T1->L2]## On the other hand, Image(t,3) produces## T1:["x"->L1:[],L2:[T1,L2,"x"]->T1,T1->L2]# # Note that a table is represented as a list of entry and assigned# values separated by ->.# ############################################################################## Problem:## The procedure here really is a combination of an earlier version and# two modifications to it. It should be re-organized to combine the# presentation style and order of expansion.## Bug:## Since the table of structures used in a call to Image is local to# that call, but the numbers used to generate unique tags are static to# the procedures that generate tags, the same structure gets different# tags in different calls of Image.#############################################################################procedure Image(x,style,done,depth,nonewline) local retval if style === 4 then return Imageb(x) # breadth-first style /style := 1 /done := table() if /depth then depth := 0 else depth +:= 2 if (style ~= 3 & depth > 0 & /nonewline) then retval := "\n" || repl(" ",depth) else retval := "" if match("record ",image(x)) then retval ||:= rimage(x,done,depth,style) else { retval ||:= case type(x) of { "list": limage(x,done,depth,style) "table": timage(x,done,depth,style) "set": simage(x,done,depth,style) default: image(x) } } depth -:= 2 return retvalend# list image#procedure limage(a,done,depth,style) static i local s, tag initial i := 0 if \done[a] then return done[a] done[a] := tag := "L" || (i +:= 1) if *a = 0 then s := tag || ":[]" else { s := tag || ":[" every s ||:= Image(!a,style,done,depth) || "," s[-1] := endof("]",depth,style) } return send# record image#procedure rimage(x,done,depth,style) static i local s, tag initial i := 0 s := image(x) # might be record constructor if match("record constructor ",s) then return s if \done[x] then return done[x] done[x] := tag := "R" || (i +:= 1) s ?:= (="record " & (":" || (tab(upto('(') + 1)))) if *x = 0 then s := tag || s || ")" else { s := tag || s every s ||:= Image(!x,style,done,depth) || "," s[-1] := endof(")",depth,style) } return send# set image#procedure simage(S,done,depth,style) static i local s, tag initial i := 0 if \done[S] then return done[S] done[S] := tag := "S" || (i +:= 1) if *S = 0 then s := tag || ":[]" else { s := tag || ":[" every s ||:= Image(!S,style,done,depth) || "," s[-1] := endof("]",depth,style) } return send# table image#procedure timage(t,done,depth,style) static i local s, tag, a, a1 initial i := 0 if \done[t] then return done[t] done[t] := tag := "T" || (i +:= 1) if *t = 0 then s := tag || ":[]" else { a := sort(t,3) := tag || ":[" while s ||:= Image(get(a),style,done,depth) || "->" || Image(get(a),style,done,depth,1) || "," s[-1] := endof("]",depth,style) } return sendprocedure endof (s,depth,style) if style = 2 then return "\n" || repl(" ",depth) || "]" else return "]"end############################################################################## What follows is the breadth-first expansion style#procedure Imageb(x, done, tags) local t if /done then { done := [set()] # done[1] actually done; done[2:0] pseudo-done tags := table() # unique label for each structure } if member(!done, x) then return tags[x] t := tagit(x, tags) # The tag for x if structure; image(x) if not if /tags[x] then return t # Wasn't a structure else { insert(done[1], x) # Mark x as actually done return case t[1] of { "R": rimageb(x, done, tags) # record "L": limageb(x, done, tags) # list "T": timageb(x, done, tags) # table "S": simageb(x, done, tags) # set } }end# Create and return a tag for a structure, and save it in tags[x].# Otherwise, if x is not a structure, return image(x).#procedure tagit(x, tags) local ximage, t, prefix static serial initial serial := table(0) if \tags[x] then return tags[x] if match("record constructor ", ximage := image(x)) then return ximage # record constructor if match("record ", t := ximage) | ((t := type(x)) == ("list" | "table" | "set")) then { prefix := map(t[1], "rlts", "RLTS") return tags[x] := prefix || (serial[prefix] +:=1) } # structure else return ximage # anything elseend# Every component sub-structure of the current structure gets tagged# and added to a pseudo-done set.#procedure defer_image(a, done, tags) local x, t t := set() every x := !a do { tagit(x, tags) if \tags[x] then insert(t, x) # if x actually is a sub-structure } put(done, t) returnend# Create the image of every component of the current structure.# Sub-structures get deleted from the local pseudo-done set before# we actually create their image.#procedure do_image(a, done, tags) local x, t t := done[-1] suspend (delete(t, x := !a), Imageb(x, done, tags))end# list image#procedure limageb(a, done, tags) local s if *a = 0 then s := tags[a] || ":[]" else { defer_image(a, done, tags) s := tags[a] || ":[" every s ||:= do_image(a, done, tags) || "," s[-1] := "]" pull(done) } return send# record image#procedure rimageb(x, done, tags) local s s := image(x) s ?:= (="record " & (":" || (tab(upto('(') + 1)))) if *x = 0 then s := tags[x] || s || ")" else { defer_image(x, done, tags) s := tags[x] || s every s ||:= do_image(x, done, tags) || "," s[-1] := ")" pull(done) } return send# set image#procedure simageb(S, done, tags) local s if *S = 0 then s := tags[S] || ":[]" else { defer_image(S, done, tags) s := tags[S] || ":[" every s ||:= do_image(S, done, tags) || "," s[-1] := "]" pull(done) } return send# table image#procedure timageb(t, done, tags) local s, a if *t = 0 then s := tags[t] || ":[]" else { a := sort(t,3) defer_image(a, done, tags) s := tags[t] || ":[" while s ||:= do_image([get(a)], done, tags) || "->" || do_image([get(a)], done, tags) || "," s[-1] := "]" pull(done) } return send :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldisort.icn
############################################################################## Name: isort.icn## Title: Customizable sort procedure## Author: Robert J. Alexander## Date: December 5, 1989############################################################################### Customizable sort procedure for inclusion in Icon programs.## isort(x,keyproc,y)## Argument x can be any Icon data type that is divisible into elements# by the unary element generation (!) operator. The result is a list# of the objects in sorted order.## The default is to sort elements in their natural, Icon-defined order.# However, an optional parameter (keyproc) allows a sort key to be# derived from each element, rather than the default of using the# element itself as the key. Keyproc can be a procedure provided by# the caller, in which case the first argument to the key procedure is# the item for which the key is to be computed, and the second argument# is isort's argument y, passed unchanged. The keyproc must produce# the extracted key. Alternatively, the keyproc argument can be an# integer, in which case it specifies a subscript to be applied to each# item to produce a key. Keyproc will be called once for each element# of structure x.#############################################################################procedure isort(x,keyproc,y) local items,item,key,result if y := integer(keyproc) then keyproc := proc("[]",2) else /keyproc := 1 items := table() every item := !x do { key := keyproc(item,y) (/items[key] := [item]) | put(items[key],item) } items := sort(items,3) result := [] while get(items) do every put(result,!get(items)) return resultend :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldlargint.icn
############################################################################## Name: largint.icn## Title: Large integer arithmetic## Author: Paul Abrahams and Ralph E. Griswold## Date: May 11, 1989############################################################################### These procedures perform addition, multiplication, and exponentiation# On integers given as strings of numerals:## add(i,j) sum of i and j## mpy(i,j) product of i and j## raise(i,j) i to the power j## Note:## The techniques used by add and mpy are different from those used by# raise. These procedures are combined here for organizational reasons.# The procedures add and mpy are adapted from the Icon language book.# The procedure raise was written by Paul Abrahams.#############################################################################record largint(coeff,nextl)global base, segsize# Add i and j#procedure add(i,j) return lstring(addl(large(i),large(j)))end# Multiply i and j#procedure mpy(i,j) return lstring(mpyl(large(i),large(j)))end# Raise i to power j#procedure raise(i,j) return rstring(ipower(i,binrep(j)))endprocedure addl(g1,g2,carry) local sum /carry := largint(0) # default carry if /g1 & /g2 then return if carry.coeff ~= 0 then carry else &null if /g1 then return addl(carry,g2) if /g2 then return addl(g1,carry) sum := g1.coeff + g2.coeff + carry.coeff carry := largint(sum / base) return largint(sum % base,addl(g1.nextl,g2.nextl,carry))endprocedure large(s) initial { base := 10000 segsize := *base - 1 } if *s <= segsize then return largint(integer(s)) else return largint(right(s,segsize), large(left(s,*s - segsize)))endprocedure lstring(g) local s if /g.nextl then s := g.coeff else s := lstring(g.nextl) || right(g.coeff,segsize,"0") s ?:= (tab(upto(~'0') | -1) & tab(0)) return sendprocedure mpyl(g1,g2) local prod if /(g1 | g2) then return &null # zero product prod := g1.coeff * g2.coeff return largint(prod % base, addl(mpyl(largint(g1.coeff),g2.nextl),mpyl(g1.nextl,g2), largint(prod / base)))end# Compute the binary representation of n (as a string)#procedure binrep(n) local retval retval := "" while n > 0 do { retval := n % 2 || retval n /:= 2 } return retvalend# Compute a to the ipower bbits, where bbits is a bit string.# The result is a list of coefficients for the polynomial a(# least significant values first, with k=10000 and zero trailing coefficient# deleted.#procedure ipower(a, bbits) local b, m1, retval m1 := (if a >= 10000 then [a % 10000, a / 10000] else [a]) retval := [1] every b := !bbits do { (retval := product(retval, retval)) | fail if b == "1" then (retval := product(retval, m1)) | fail } return retvalend# Compute a*b as a polynomial in the same form as for ipower.# a and b are also polynomials in this form.#procedure product(a,b) local i, j, k, retval, x if *a + *b > 5001 then fail retval := list(*a + *b, 0) every i := 1 to *a do every j := 1 to *b do { k := i + j - 1 retval[k] +:= a[i] * b[j] while (x := retval[k]) >= 10000 do { retval[k + 1] +:= x / 10000 retval[k] %:= 10000 k +:= 1 } } every i := *retval to 1 by -1 do if retval[i] > 0 then return retval[1+:i] return retval[1+:i]endprocedure rstring(n) local ds, i, j, k, result ds := "" every k := *n to 1 by -1 do ds ||:= right(n[k], 4, "0") ds ?:= (tab(many("0")), tab(0)) ds := repl("0", 4 - (*ds - 1) % 5) || ds result := "" every i := 1 to *ds by 50 do { k := *ds > i + 45 | *ds every j := i to k by 5 do { ds result ||:= ds[j+:5] } } result ? { tab(many('0')) return tab(0) }end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldlmap.icn
############################################################################## Name: lmap.icn## Title: Map list elements## Author: Ralph E. Griswold## Date: June 10, 1988############################################################################## # The procedure lmap(L1,L2,L3) maps elements of L1 according to L2# and L3. This procedure is the analog for lists of the built-in# string-mapping function map(s1,s2,s3). Elements in L1 that are# the same as elements in L2 are mapped into the corresponding ele-# ments of L3. For example, given the lists# # L1 := [1,2,3,4]# L2 := [4,3,2,1]# L3 := ["a","b","c","d"]# # then# # lmap(L1,L2,L3)# # produces a new list# # ["d","c","b","a"]# # Lists that are mapped can have any kinds of elements. The# operation# # x === y# # is used to determine if elements x and y are equivalent.# # All cases in lmap are handled as they are in map, except that# no defaults are provided for omitted arguments. As with map, lmap# can be used for transposition as well as substitution.# # Warning:## If lmap is called with the same lists L2 and L3 as in# the immediately preceding call, the same mapping is performed,# even if the values in L2 and L3 have been changed. This improves# performance, but it may cause unexpected effects.# # This ``caching'' of the mapping table based on L2 and L3# can be easily removed to avoid this potential problem.# ############################################################################procedure lmap(L1,L2,L3) static lmem2, lmem3, lmaptbl, tdefault local i, a initial tdefault := [] if type(a := L1 | L2 | L3) ~== "list" then runerr(108,a) if *L2 ~= *L3 then runerr(208,L2) L1 := copy(L1) if not(lmem2 === L2 & lmem3 === L3) then { # if an argument is new, rebuild lmem2 := L2 # save for future reference lmem3 := L3 lmaptbl := table(tdefault) # new mapping table every i := 1 to *L2 do # build the map lmaptbl[L2[i]] := L3[i] } every i := 1 to *L1 do # map the values L1[i] := (tdefault ~=== lmaptbl[L1[i]]) return L1end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldmapbit.icn
############################################################################## Name: mapbit.icn## Title: Map string into bit representation## Author: Ralph E. Griswold## Date: January 2, 1990############################################################################### The procedure mapbit(s) produces a string of zeros and ones# corresponding to the bit patterns for the characters of s. For# example, mapbit("Axe") produces "010000010111100001100101".############################################################################### Links: collate#############################################################################link collateprocedure bilit(text,alpha,first,second) return collate(map(text,alpha,first),map(text,alpha,second))endprocedure mapbit(s) static all, base16, hex1, hex2, quad1, quad2, pair1, pair2 # The following is a bit ornate, but then ... . It could be # made more compact (and cryptic) by using lists of templates # and parameterizing the initialization. initial { all := string(&cset) base16 := "0123456789ABCDEF" hex1 := "" every hex1 ||:= repl(!base16,16) hex2 := repl(base16,16) quad1 := "" every quad1 ||:= repl(!left(base16,4),4) quad2 := repl(left(base16,4),4) pair1 := "" every pair1 ||:= repl(!left(base16,2),2) pair2 := repl(left(base16,2),2) } s := bilit(bilit(bilit(s,all,hex1,hex2),base16,quad1,quad2),left(base16,4), pair1,pair2) return send :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldmath.icn
############################################################################## Name: math.icn## Title: Perform mathematical computations## Author: George D. Yee## Date: June 10, 1988############################################################################### Note:# Version 8 of Icon supports most of the procedures that follow as# built-in functions. The procedures here should not be used unless the# corresponding functions are disabled.############################################################################## # The following procedures compute standard trigonometric func-# tions. The arguments are in radians.# # sin(x) sine of x# # cos(x) cosine of x# # tan(x) tangent of x# # asin(x) arc sine of x in the range -pi/2 to pi/2# # acos(x) arc cosine of x in the range 0 to pi# # atan(x) arc tangent of x in the range -pi/2 to pi/2# # atan2(y,x) arc tangent of x/y in the range -pi to pi# # The following procedures convert from degrees to radians and con-# versely:# # dtor(d) radian equivalent of d# # rtod(r) degree equivalent of r# # The following additional procedures are available:# # sqrt(x) square root of x# # exp(x) exponential function of x# # log(x) natural logarithm of x# # log10(x) base-10 logarithm of x# # floor(x) largest integer not greater than x# # ceil(x) smallest integer nor less than x# # Failure Conditions: asin(x) and acos(x) fail if the absolute# value of x is greater than one. sqrt(x), log(x), and log10(x)# fail if x is less than zero.# ############################################################################procedure sin(x) return _sinus(numeric(x),0)endprocedure cos(x) return _sinus(abs(numeric(x)),1)endprocedure tan(x) return sin(x) / (0.0 ~= cos(x))end# atan returns the value of the arctangent of its# argument in the range [-pi/2,pi/2].procedure atan(x) if numeric(x) then return if x > 0.0 then _satan(x) else -_satan(-x)end# atan2 returns the arctangent of y/x# in the range [-pi,pi].procedure atan2(y,x) local r static pi initial pi := 3.141592653589793238462643 return if numeric(y) & numeric(x) then { if x > 0.0 then atan(y/x) else if x < 0.0 then { r := pi - atan(abs(y/x)) if y >= 0.0 then r else -r } else if x = y = 0.0 then 0.0 # special value if both x and y are zero else if y >= 0.0 then pi/2.0 else -pi/2.0 }endprocedure asin(x) if abs(numeric(x)) <= 1.0 then return atan2(x, (1.0-(x^2))^0.5)endprocedure acos(x) return 1.570796326794896619231e0 - asin(x)endprocedure dtor(deg) return numeric(deg)/57.29577951308232endprocedure rtod(rad) return numeric(rad)*57.29577951308232endprocedure sqrt(x) return (0.0 <= numeric(x)) ^ 0.5endprocedure floor(x) return if numeric(x) then if x>=0.0 | real(x)=integer(x) then integer(x) else -integer(-x+1)endprocedure ceil(x) return -floor(-numeric(x))endprocedure log(x) local z, zsq, ex static log2, sqrto2, p0, p1, p2, p3, q0, q1, q2 initial { # The coefficients are #2705 from Hart & Cheney. (19.38D) log2 := 0.693147180559945309e0 sqrto2 := 0.707106781186547524e0 p0 := -0.240139179559210510e2 p1 := 0.309572928215376501e2 p2 := -0.963769093368686593e1 p3 := 0.421087371217979714e0 q0 := -0.120069589779605255e2 q1 := 0.194809660700889731e2 q2 := -0.891110902798312337e1 } if numeric(x) > 0.0 then { ex := 0 while x >= 1.0 do { x /:= 2.0 ex +:= 1 } while x < 0.5 do { x *:= 2.0 ex -:= 1 } if x < sqrto2 then { x *:= 2.0 ex -:= 1 } return ((((p3*(zsq:=(z:=(x-1.0)/(x+1.0))^2)+p2)*zsq+p1)*zsq+p0)/ (((1.0*zsq+q2)*zsq+q1)*zsq+q0))*z+ex*log2 }endprocedure exp(x) return 2.718281828459045235360287 ^ numeric(x)endprocedure log10(x) return log(x)/2.30258509299404568402endprocedure _sinus(x,quad) local ysq, y, k static twoopi, p0, p1, p2, p3, p4, q0, q1, q2, q3 initial { # Coefficients are #3370 from Hart & Cheney (18.80D). twoopi := 0.63661977236758134308 p0 := 0.1357884097877375669092680e8 p1 := -0.4942908100902844161158627e7 p2 := 0.4401030535375266501944918e6 p3 := -0.1384727249982452873054457e5 p4 := 0.1459688406665768722226959e3 q0 := 0.8644558652922534429915149e7 q1 := 0.4081792252343299749395779e6 q2 := 0.9463096101538208180571257e4 q3 := 0.1326534908786136358911494e3 } if x < 0.0 then { x := -x quad +:= 2 } y := (x *:= twoopi) - (k := integer(x)) if (quad := (quad + k) % 4) = (1|3) then y := 1.0 - y if quad > 1 then y := -y return (((((p4*(ysq:=y^2)+p3)*ysq+p2)*ysq+p1)*ysq+p0)*y) / ((((ysq+q3)*ysq+q2)*ysq+q1)*ysq+q0)endprocedure _satan(x) static sq2p1,sq2m1,pio2,pio4 initial { sq2p1 := 2.414213562373095048802e0 sq2m1 := 0.414213562373095048802e0 pio2 := 1.570796326794896619231e0 pio4 := 0.785398163397448309615e0 } return if x < sq2m1 then _xatan(x) else if x > sq2p1 then pio2 - _xatan(1.0/x) else pio4 + _xatan((x-1.0)/(x+1.0))endprocedure _xatan(x) local xsq static p4,p3,p2,p1,p0,q4,q3,q2,q1,q0 initial { # coefficients are #5077 from Hart & Cheney. (19.56D) p4 := 0.161536412982230228262e2 p3 := 0.26842548195503973794141e3 p2 := 0.11530293515404850115428136e4 p1 := 0.178040631643319697105464587e4 p0 := 0.89678597403663861959987488e3 q4 := 0.5895697050844462222791e2 q3 := 0.536265374031215315104235e3 q2 := 0.16667838148816337184521798e4 q1 := 0.207933497444540981287275926e4 q0 := 0.89678597403663861962481162e3 } return x * ((((p4*(xsq:=x^2)+p3)*xsq+p2)*xsq+p1)*xsq+p0) / (((((xsq+q4)*xsq+q3)*xsq+q2)*xsq+q1)*xsq+q0)end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldmorse.icn
############################################################################## Name: morse.icn## Title: Convert string to Morse code## Author: Ralph E. Griswold## Date: June 10, 1988############################################################################### This procedure converts the string s to its Morse code equivalent.#############################################################################procedure morse(s) local i, t, c, x static morsemeander, morseindex initial { morsemeander := "....------.----..---.-.---...--.--._ -..--..-.--....-.-.-...-..-....." morseindex := "TMOT09TTT1T8TT2GQTTTJTZ7T3NKYTTCTTT_ TDXTTWPTB64EARTTLTVTIUFTSH5" } x := "" every c := !map(s,&lcase,&ucase) do if not(i := upto(c,morseindex)) then x := x || " " else { t := morsemeander[i+:6] x := x || t[upto("-",t)+1:0] || " " } return xend :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldngrams.icn
############################################################################## Name: ngrams.icn## Title: Generate n-grams## Author: Ralph E. Griswold## Date: June 10, 1988############################################################################### The procedure ngrams(file,n,c,t) generates a tabulation of the n-grams# in the specified file. If c is non-null, it is used as the set of# characters from which n-grams are taken (other characters break n-grams).# The default for c is the upper- and lowercase letters. If t is non-null,# the tabulation is given in order of frequency; otherwise in alphabetical# order of n-grams.## Note:## The n-grams are kept in a table within the procedure and all n-grams# are processed before the tabulation is generated. Consequently, this# procedure is unsuitable if there are very many different n-grams.#############################################################################procedure ngrams(f,i,c,t) local line, grams, a, count if not (integer(i) > 0) then stop("invalid ngrams specification") if type(f) ~== "file" then stop("invalid file specification") /c := &lcase || &ucase if not (c := cset(c)) then stop("invalid cset specification") grams := table(0) line := "" while line ||:= reads(f,1000) do line ? while tab(upto(c)) do (tab(many(c)) \ 1) ? while grams[move(i)] +:= 1 do move(-i + 1) if /t then { a := sort(grams,4) while count := pull(a) do suspend pull(a) || right(count,8) } else { a := sort(grams,3) suspend |(get(a) || right(get(a),8)) }end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldnumbers.icn
############################################################################## Name: numbers.icn## Title: Format and convert numbers## Author: Ralph E. Griswold and Tim Korb## Date: December 27, 1989############################################################################### These procedures format numbers in various ways:## commas(s) inserts commas in s to separate digits into groups of# three.## roman(i) converts s to Roman numerals.## spell(i) spells out i in English.## fix(i,j,w) formats i / j as a real (floating-point) number in# a field of width w with three digits to the right of# the decimal point, if possible.############################################################################### Bug:## The procedure fix() should be more general.#############################################################################procedure commas(n) if *n < 4 then return n else return commas(left(n,*n - 3)) || map(",123","123",right(n,3))end# This procedure is based on a SNOBOL4 function written by Jim Gimpel.#procedure roman(n) local arabic, result static equiv initial equiv := ["","I","II","III","IV","V","VI","VII","VIII","IX"] integer(n) > 0 | fail result := "" every arabic := !n do result := map(result,"IVXLCDM","XLCDM**") || equiv[arabic + 1] if find("*",result) then fail else return resultendprocedure spell(n) local m n := integer(n) | stop(image(n)," is not an integer") if n <= 12 then return { "0zero,1one,2two,3three,4four,5five,6six,7seven,8eight,_ 9nine,10ten,11eleven,12twelve," ? { tab(find(n)) move(*n) tab(upto(",")) } } else if n <= 19 then return { spell(n[2] || "0") ? (if ="for" then "four" else tab(find("ty"))) || "teen" } else if n <= 99 then return { "2twen,3thir,4for,5fif,6six,7seven,8eigh,9nine," ? { tab(upto(n[1])) move(1) tab(upto(",")) || "ty" || if n[2] ~= 0 then "-" || spell(n[2]) } } else if n <= 999 then return { spell(n[1]) || " hundred" || (if (m := n[2:0]) ~= 0 then " and " || spell(m) else "") } else if n <= 999999 then return { spell(n[1:-3]) || " thousand" || (if (m := n[2:0]) ~= 0 then " and " || spell(m) else "") } else if n <= 999999999 then return { spell(n[1:-6]) || " million" || (if (m := n[2:0]) ~= 0 then " and " || spell(m) else "") } else failendprocedure fix(i,j,w) /j := 1 /w := 5 if j = 0 then fail if w < 5 then w := 5 r := real(i) / j if r < 0.001 then return repl(" ",w - 5) || "0.000" string(r) ? { int := tab(upto('.')) move(1) dec := tab(0) } return right(int,w - 4) || "." || left(dec,3,"0")end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldobject.icn
############################################################################## Name: object.icn## Title: Encode and decode Icon values## Author: Kurt A. Welgehausen## Date: June 10, 1988############################################################################### These procedures provide a way of storing Icon values as strings in# files and reconstructing them.## putobj(obj, f) stores the Icon data object obj in the file f; it returns# the object stored. The returned value is usually not of interest, so a# typical call is putobj(x, f).# # The file f must be open for writing; if f is null, it defaults to &output.# # Strings are stored as single lines in the file, with unprintable# characters stored as the escape sequences produced by image(). # # Integers, reals, and csets are writen to the file as single lines of the# form "%"type(obj)string(obj), for example # # 123 is stored as "%integer123"# 123.4 is stored as "%real123.4"# '123' is stored as "%cset123"# # As in strings, unprintable characters in csets are stored as the escape # sequences produced by image().# # Procedures, functions,and record constructors are stored as strings of the# form # "%proc"procedure-name. For example, the function write() is stored# as "%procwrite".# # Files are stored as strings of the form "#file("file-name")". For# example, if f is a file variable connected to the disk file example.fil,# then f is stored by putobj() as "#file(example.fil)". # # Co-expressions are stored as the string "#co-expr".# # Null objects are stored as lines containing only "%".# # Structured objects are stored as single lines of the form# "%"type(obj)"("n")", where n is the size of obj, followed by the n# components of obj (tables are stored as their default assigned values# followed by sorted lists of index and # assigned values). putobj() calls# itself recursively to store the components. For example,## ["aaa", ["bbb", 'edc'], 16rfff, open("somefile"), create write(1 to 3)]## is stored as # # %list(5)# aaa# %list(2)# bbb# %csetcde# %integer4095# #file(somefile)# #co-expr# # # getobj(f) retrieves an Icon data object from the file f; it returns the # object. A typical call is "x := getobj(f)".# # The file f must be open for reading; if f is null, it defaults to &input.# # The object to be retrieved must have been stored in the format used by# putobj().# # No attempt is made to reconstruct file variables or co-expressions; only# the descriptive string is returned. It is up to the programmer to open the# file or recreate the co-expression. For all other types, the actual Icon# object is returned. # ############################################################################## Warning:## putobj(x) calls itself to process structures in x. If there is a# loop in the structure, putobj(x) gets stack overflow due to excessive# recursion.## Objects stored with putobj() and then retrieved with getobj() may# not be identical to the original objects. For example, if x is an Icon# structure and y := [x, x], then y[1] and y[2] are identical; but # after storing and retrieving y, y[1] and y[2] will be copies of each # other but will not be the same object.## To avoid these problems, use codeobj.icn instead of object.icn.# ############################################################################## Links: escape## See also: codeobj.icn#############################################################################link escapeglobal HDRSYM, ESCSYMprocedure getobj(f) local line, buf, otype, size initial { /HDRSYM:= "%"; /ESCSYM:= "@" } # these defs must be the same as # those in putobj() /f:= &input (line:= (read(f) | fail)) ? { case move(1) | "" of { ESCSYM: buf:= escape(tab(0)) HDRSYM: { (otype:= tab(upto('(')), move(1), size:= integer(tab(upto(')')))) | (buf:= (=("integer" | "real" | "cset" | "proc"))(escape(tab(0)))) | &null # must succeed } "&": buf:= case tab(0) of { "input": &input ; "output": &output ; "errout": &errout "cset": &cset ; "ascii": &ascii "lcase": &lcase ; "ucase": &ucase } default: buf:= escape(line) } } \size & { # not-null size means a structured type ((otype == "table") & (buf:= getobj(f))) | ((otype == "set") & (buf:= [])) buf:= otype(buf) case otype of { "list": every 1 to size do put(buf, getobj(f)) "table": every 1 to size do buf[getobj(f)]:= getobj(f) "set": every 1 to size do insert(buf, getobj(f)) default: every buf[1 to size]:= getobj(f) } } return bufend# Put object <obj> on file <f>; <f> must be open for writing.# If <f> is not specified, output goes to &output.global HDRSYM, ESCSYMprocedure putobj(obj, f) local t, buf initial { /HDRSYM:= "%"; /ESCSYM:= "@" } # these defs must be the same as # those in getobj() /f:= &output case t:= type(obj) of { "string": { match(ESCSYM | HDRSYM | "&", obj) & (obj:= ESCSYM || obj) write(f, image(obj)[2:-1]) } "integer" | "real": write(f, HDRSYM, t, obj) "cset": { buf:= image(obj) (match("&", buf) & write(f, buf)) | write(f, HDRSYM, t, buf[2:-1]) } "null": write(f, HDRSYM) "procedure": image(obj) ? { =("procedure " | "function " | "record constructor ") write(f, HDRSYM, "proc", tab(0)) } "file": image(obj) ? write(f, (="&" | "#") || tab(0)) "co-expression": write(f, "#", t[1:8]) default: { write(f, HDRSYM, t, "(", *obj, ")") (t == "table", putobj(obj[[]], f), buf:= sort(obj, 3)) | (buf:= obj) (*buf > 0) & every putobj(!buf, f) } } return objend :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldoptions.icn
############################################################################## Name: options.icn## Title: Get command-line options## Authors: Robert J. Alexander and Gregg M. Townsend## Date: November 9, 1989############################################################################## # options(arg,optstring) -- Get command line options.# # This procedure analyzes the -options on the command line# invoking an Icon program. The inputs are:# # arg the argument list as passed to the main procedure.## optstring a string of allowable option letters. If a# letter is followed by ":" the corresponding# option is assumed to be followed by a string of# data, optionally separated from the letter by# space. If instead of ":" the letter is followed# by a "+", the parameter will converted to an# integer; if a ".", converted to a real. If opt-# string is omitted any letter is assumed to be# valid and require no data.# # It returns a table containing the options that were specified.# The keys are the specified option letters. The assigned values are# the data words following the options, if any, or 1 if the option# has no data. The table's default value is &null.# # If an error is detected, stop() is called with an appropriate# error message.## Options may be freely interspersed with non-option arguments.# An argument of "-" is treated as a non-option. The special argument# "--" terminates option processing. Non-option arguments are returned# in the original argument list for interpretation by the caller.# ############################################################################procedure options(arg,optstring) local x,i,c,otab,flist,o,p /optstring := string(&letters) otab := table() flist := [] while x := get(arg) do x ? { if ="-" & not pos(0) then { if ="-" & pos(0) then break while c := move(1) do if i := find(c,optstring) + 1 then otab[c] := if any(':+.',o := optstring[i]) then { p := "" ~== tab(0) | get(arg) | stop("No parameter following -",c) case o of { ":": p "+": integer(p) | stop("-",c," needs numeric parameter") ".": real(p) | stop("-",c," needs numeric parameter") } } else 1 else stop("Unre option: -",c) } else put(flist,x) } while push(arg,pull(flist)) return otabend :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldpatterns.icn
############################################################################## Name: patterns.icn## Title: Pattern matching in the style of SNOBOL4## Author: Ralph E. Griswold## Date: June 10, 1988############################################################################## # These procedures provide procedural equivalents for most SNOBOL4# patterns and some extensions. ## Procedures and their pattern equivalents are:# # Any(s) ANY(S)# # Arb() ARB# # Arbno(p) ARBNO(P)# # Arbx(i) ARB(I)# # Bal() BAL# # Break(s) BREAK(S)# # Breakx(s) BREAKX(S)# # Cat(p1,p2) P1 P2# # Discard(p) /P# # Exog(s) \S# # Find(s) FIND(S)# # Len(i) LEN(I)# # Limit(p,i) P \ i# # Locate(p) LOCATE(P)# # Marb() longest-first ARB# # Notany(s) NOTANY(S)# # Pos(i) POS(I)# # Replace(p,s) P = S# # Rpos(i) RPOS(I)# # Rtab(i) RTAB(I)# # Span(s) SPAN(S)# # String(s) S# # Succeed() SUCCEED# # Tab(i) TAB(I)# # Xform(f,p) F(P)# # The following procedures relate to the application and control# of pattern matching:# # Apply(s,p) S ? P# # Mode() anchored or unanchored matching (see Anchor# and Float)# # Anchor() &ANCHOR = 1 if Mode := Anchor# # Float() &ANCHOR = 0 if Mode := Float# # In addition to the procedures above, the following expressions# can be used:# # p1() | p2() P1 | P2# # v <- p() P . V (approximate)# # v := p() P $ V (approximate)# # fail FAIL# # =s S (in place of String(s))# # p1() || p2() P1 P2 (in place of Cat(p1,p2))# # Using this system, most SNOBOL4 patterns can be satisfactorily# transliterated into Icon procedures and expressions. For example,# the pattern# # SPAN("0123456789") $ N "H" LEN(*N) $ LIT# # can be transliterated into# # (n <- Span('0123456789')) || ="H" ||# (lit <- Len(n))# # Concatenation of components is necessary to preserve the# pattern-matching properties of SNOBOL4.# # Caveats: Simulating SNOBOL4 pattern matching using the procedures# above is inefficient.# ############################################################################global Mode, Floatprocedure Anchor() # &ANCHOR = 1 suspend ""endprocedure Any(s) # ANY(S) suspend tab(any(s))endprocedure Apply(s,p) # S ? P local tsubject, tpos, value initial { Float := Arb /Mode := Float # &ANCHOR = 0 if not already set } suspend ( (tsubject := &subject) & (tpos := &pos) & (&subject <- s) & (&pos <- 1) & (Mode() & (value := p())) & (&pos <- tpos) & # to restore on backtracking (&subject <- tsubject) & # note this sets &pos (&pos <- tpos) & # to restore on evaluation value )endprocedure Arb() # ARB suspend tab(&pos to *&subject + 1)endprocedure Arbno(p) # ARBNO(P) suspend "" | (p() || Arbno(p))endprocedure Arbx(i) # ARB(I) suspend tab(&pos to *&subject + 1 by i)endprocedure Bal() # BAL suspend Bbal() || Arbno(Bbal)endprocedure Bbal() # used by Bal() suspend (="(" || Arbno(Bbal) || =")") | Notany("()")endprocedure Break(s) # BREAK(S) suspend tab(upto(s) \ 1)endprocedure Breakx(s) # BREAKX(S) suspend tab(upto(s))endprocedure Cat(p1,p2) # P1 P2 suspend p1() || p2()endprocedure Discard(p) # /P suspend p() & ""endprocedure Exog(s) # \S suspend sendprocedure Find(s) # FIND(S) suspend tab(find(s) + 1)endprocedure Len(i) # LEN(I) suspend move(i)endprocedure Limit(p,i) # P \ i local j j := &pos suspend p() \ i &pos := jendprocedure Locate(p) # LOCATE(P) suspend tab(&pos to *&subject + 1) & p()endprocedure Marb() # max-first ARB suspend tab(*&subject + 1 to &pos by -1)endprocedure Notany(s) # NOTANY(S) suspend tab(any(~s))endprocedure Pos(i) # POS(I) suspend pos(i + 1) & ""endprocedure Replace(p,s) # P = S suspend p() & sendprocedure Rpos(i) # RPOS(I) suspend pos(-i) & ""endprocedure Rtab(i) # RTAB(I) suspend tab(-i)endprocedure Span(s) # SPAN(S) suspend tab(many(s))endprocedure String(s) # S suspend =sendprocedure Succeed() # SUCCEED suspend |""endprocedure Tab(i) # TAB(I) suspend tab(i + 1)endprocedure Xform(f,p) # F(P) suspend f(p())end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldpatword.icn
############################################################################## Name: patword.icn## Title: Letter patterns in words## Author: Kenneth Walker## Date: June 10, 1988############################################################################### The procedure patword(s) returns a letter pattern in which each# different character in s is assigned a letter. For example,# patword("structural") returns "abcdedbcfg".#############################################################################procedure patword(s) local numbering, orderS, orderset, patlbls static labels, revnum initial { labels := &lcase || &lcase revnum := reverse(&cset) }# First map each character of s into another character, such that the# the new characters are in increasing order left to right (note that# the map function chooses the rightmost character of its second# argument, so things must be reversed.## Next map each of these new characters into contiguous letters. numbering := revnum[1 : *s + 1] | stop("word too long") orderS := map(s, reverse(s), numbering) orderset := string(cset(orderS)) patlbls := labels[1 : *orderset + 1] | stop("too many characters") return map(orderS, orderset, patlbls)end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldpdae.icn
## Name: pdae.icn## Title: Programmer-defined argument evaluation## Author: Ralph E. Griswold## Date: January 1, 1990############################################################################## # These procedures use co-expressions to model the built-in argu-# ment evaluation regime of Icon and also provide new ones.# # Allpar{e1,e2, ...} parallel evaluation with last result# used for short sequences# # Extract{e1,e2, ...} extract results of even-numbered argu-# ments according to odd-numbered values# # Lifo{e1,e2, ...} models standard Icon ``lifo'' evalua-# tion# # Parallel{e1,e2, ...} parallel evaluation terminating on# shortest sequence# # Reverse{e1,e2, ...} left-to-right reversal of lifo evalua-# tion# # Rotate{e1,e2, ...} parallel evaluation with shorter# sequences re-evaluated# # Simple{e1,e2, ...} simple evaluation with only success or# failure## In all cases, the first argument is "applied".## Comments:## Because of the handling of the scope of local identif-# iers in co-expressions, expressions in programmer-defined argu-# ment evaluation regimes cannot communicate through local identif-# iers. Some constructions, such as break and return, cannot be# used in arguments to programmer-defined argument evaluation# regimes.# ############################################################################## Requires: co-expressions#############################################################################procedure Allpar(a) local i, x, done x := list(*a) done := list(*a,1) every i := 1 to *a do x[i] := @a[i] | fail repeat { suspend x[1]!x[2:0] every i := 1 to *a do if done[i] = 1 then ((x[i] := @a[i]) | (done[i] := 0)) if not(!done = 1) then fail }endprocedure Extract(a) local i, j, n, x x := list(*a/2) repeat { i := 1 while i < *a do { n := @a[i] | fail every 1 to n do x[(i + 1)/2] := @a[i + 1] | fail a[i + 1] := ^a[i + 1] i +:= 2 } suspend x[1]!x[2:0] }endprocedure Lifo(a) local i, x, ptr x := list(*a) ptr := 1 repeat { repeat if x[ptr] := @a[ptr] then { ptr +:= 1 (a[ptr] := ^a[ptr]) | break } else if (ptr -:= 1) = 0 then fail suspend x[1]!x[2:0] ptr := *a }endprocedure Parallel(a) local i, x x := list(*a) repeat { every i := 1 to *a do x[i] := @a[i] | fail suspend x[1]!x[2:0] }endprocedure Reverse(a) local i, x, ptr x := list(*a) ptr := *a repeat { repeat if x[ptr] := @a[ptr] then { ptr -:= 1 (a[ptr] := ^a[ptr]) | break } else if (ptr +:= 1) > *a then fail suspend x[1]!x[2:0] ptr := 1 }endprocedure Rotate(a) local i, x, done x := list(*a) done := list(*a,1) every i := 1 to *a do x[i] := @a[i] | fail repeat { suspend x[1]!x[2:0] every i := 1 to *a do if not(x[i] := @a[i]) then { done[i] := 0 if !done = 1 then { a[i] := ^a[i] x[i] := @a[i] | fail } else fail } }endprocedure Simple(a) local i, x x := list(*a) every i := 1 to *a do x[i] := @a[i] | fail return x[1]!x[2:0]end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldpdco.icn
############################################################################## Name: pdco.icn## Title: Programm-defined control operations## Author: Ralph E. Griswold## Date: November 16, 1989############################################################################## # These procedures use co-expressions to used to model the built-in# control structures of Icon and also provide new ones.# # Alt{e1,e2} models e1 | e2# # Colseq{e1,e2, ...} produces results of e1, e2, ... alter-# nately# # Comseq{e1,e2} compares result sequences of e1 and e2# # Cond{e1,e2, ...} models the generalized Lisp conditional# # Every{e1,e2} models every e1 do e2# # Galt{e1,e2, ...} models generalized alternation: e1 | e2 |# ...# # Lcond{e1,e2, ...} models the Lisp conditional# # Limit{e1,e2} models e1 \ e2# # Ranseq{e1,e2, ...} produces results of e1, e2, ... at random# # Repalt{e} models |e# # Resume{e1,e2,e3} models every e1 \ e2 do e3# # Select{e1,e2} produces results from e1 by position# according to e2# # Comments:## Because of the handling of the scope of local identif-# iers in co-expressions, expressions in programmer-defined control# operations cannot communicate through local identifiers. Some# constructions, such as break and return, cannot be used in argu-# ments to programmer-defined control operations.# ############################################################################## Requires: co-expressions#############################################################################procedure Alt(L) local x while x := @L[1] do suspend x while x := @L[2] do suspend xendprocedure Colseq(L) suspend |@!Lendprocedure Comseq(L) local x1, x2 while x1 := @L[1] do (x1 === @L[2]) | fail if @L[2] then fail else return *L[1]endprocedure Cond(L) local i, x every i := 1 to *l do if x := @L[i] then { suspend x suspend |@L[i] fail }endprocedure Every(L) while @L[1] do @^L[2]endprocedure Galt(L) local C every C := !L do suspend |@Cendprocedure Lcond(L) local i every i := 1 to *L by 2 do if @L[i] then { suspend |@L[i + 1] fail }endprocedure Limit(L) local i, x while i := @L[2] do { every 1 to i do if x := @L[1] then suspend x else break L[1] := ^L[1] }endprocedure Ranseq(L) local x while x := @?L do suspend xendprocedure Repalt(L) local x repeat { while x := @L[1] do suspend x if *L[1] = 0 then fail else L[1] := ^L[1] }endprocedure Resume(L) local i while i := @L[2] do { L[1] := ^L[1] every 1 to i do if @L[1] then @^L[3] else break }endprocedure Select(L) local i, j, x j := 0 while i := @L[2] do { while j < i do if x := @L[1] then j +:= 1 else fail if i = j then suspend x else stop("selection sequence error") }end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldpermute.icn
############################################################################## Name: permute.icn## Title: Permutations, combinations, and such## Author: Ralph E. Griswold and Kurt A. Welgehausen## Date: May 9, 1989############################################################################### These procedures produce various rearrangements of strings of# characters:## comb(s,i) generates the combinations characters from s taken# i at a time.## permute(s) generates all the permutations of the string s.## menader(s,n) produces a "meandering" string which contains all# n-tuples of characters of s.## csort(s) produces the characters of s in lexical order.## ochars(s) produces the unique characters of s in the order they# first appear in s.## schars(s) produces the unique characters of s in lexical order.#############################################################################procedure comb(s,i) local j if i < 1 then fail suspend if i = 1 then !s else s[j := 1 to *s - i + 1] || comb(s[j + 1:0],i - 1)endprocedure permute(s) local i if *s = 0 then return "" suspend s[i := 1 to *s] || permute(s[1:i] || s[i+1:0])endprocedure meander(alpha,n) local result, t, i, c, k i := k := *alpha t := n - 1 result := repl(alpha[1],t) while c := alpha[i] do { if find(result[-t:0] || c,result) then i -:= 1 else { result ||:= c i := k } } return resultendprocedure csort(s) local c, s1 s1 := "" every c := !cset(s) do every find(c,s) do s1 ||:= c return s1endprocedure schars(s) return string(cset(s))endprocedure ochars(w) local out, c out := "" every c := !w do if not find(c,out) then out ||:= c return outend :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldphoname.icn
############################################################################## Name: phoname.icn## Title: Generate letter combinations for phone numbers## Author: Unknown## Date: June 10, 1988############################################################################### This procedure generates the letter combinations corresponding to the# digits in a telephone number.## Warning:## The number of possibilities is very large. This procedure should be# used in a context that limits or filters its output.#############################################################################procedure phoname(number) local buttons, nondigits, pstr, t, x buttons := ["000","111","abc","def","ghi","jkl","mno", "prs","tuv","wxy"] nondigits := ~&digits pstr := stripstr(number,nondigits) if 7 ~= *pstr then fail t := [] every x := !pstr do put(t,buttons[x+1]) suspend !t[1] || !t[2] || !t[3] || !t[4] || !t[5] || !t[6] || !t[7]endprocedure stripstr(str,delchs) local i i := 1 while i <= *str do { if any(delchs,str,i) then str[i] := "" else i +:= 1 } return strend # stripstr :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldprintcol.icn
############################################################################## Name: printcol.icn## Title: Format columnar data## Author: Robert J. Alexander## Date: June 10, 1988############################################################################## # This procedure deals with with the problem of printing tabular# data where the total width of items to be printed is wider than# the page. Simply allowing the data to wrap to additional lines# often produces marginally readable output. This procedure facil-# itates printing such groups of data as vertical columns down the# page length, instead of as horizontal rows across the page. That# way many, many fields can be printed neatly. The programming of# such a transformation can be a nuisance. This procedure does# much of the work for you, like deciding how many items can fit# across the page width and ensuring that entire items will be# printed on the same page without page breaks (if that service is# requested).# # For example, suppose we have a list of records we would like# to print. The record is defined as:# # record rec(item1,item2,item3,...)# # Also suppose that lines such as# # Field 1 Field 2 Field 3 ...# ------- ------- ------- ---# Record 1 item1 item2 item3 ...# Record 2 item1 item2 item3 ...# # are too long to print across the page. This procedure will print# them as:# # TITLE# =====# Record 1 Record 2 ...# -------- -------- ---# Field 1 item1 item1 ...# Field 2 item2 item2 ...# Field 3 item3 item3 ...# # The arguments are:# # items: a co-expression that produces a sequence of# items (usually structured data objects, but not# necessarily) for which data is to be printed.# # fields: a list of procedures to produce the field's# data. Each procedure takes two arguments. The# procedure's action depends upon what is passed# in the first argument:# # header Produces the row heading string to be used# for that field (the field name).# # width Produces the maximum field width that can# be produced (including the column header).# # Other Produces the field value string for the# item passed as the argument.# # The second argument is arbitrary data from the procedures# with each invocation. The data returned by the first func-# tion on the list is used as a column heading string (the# item name).# # title: optional.# # # pagelength: if null (omitted) page breaks are ignored.# # linelength: default 80.# # auxdata: auxiliary arbitrary data to be passed to the field# procedures -- see `fields', above.# ############################################################################procedure printcol(items,fields,title,pagelength,linelength,auxdata) local maxwidth,maxhead,groups,columns,itemlist,cont,f,p,underline, hfield /linelength := 80 /pagelength := 30000 /title := ""## Compute the maximum field width (so we know the column spacing) and# the maximum header width (so we know how much space to leave on the# left for headings.# maxwidth := maxhead := -1 cont := "" every maxwidth <:= (!fields)("width",auxdata) hfield := get(fields) every maxhead <:= *(!fields)("header",auxdata) columns := (linelength - maxhead) / (maxwidth + 1) groups := pagelength / (6 + *fields)## Loop to print groups of data.# repeat { if pagelength < 30000 then writes("\f")## Loop to print data of a group (a page's worth).# every 1 to groups do {## Collect the items to be output in this group. A group is the number# of columns that can fit across the page.# itemlist := [] every 1 to columns do put(itemlist,@items) | break if *itemlist = 0 then break break## Print a title and the column headings.# write(repl("=",*write("\n",title || cont))) cont := " (continued)" writes(underline := left("",maxhead)) every f := hfield(!itemlist,auxdata) do { p := if *f < maxwidth then center else left writes(" ",p(f,maxwidth)) underline ||:= " " || p(repl("-",*f),maxwidth) } write("\n",underline)## Print the fields.# every f := !fields do { writes(right(f("header",auxdata),maxhead)) every writes(" ",center(f(!itemlist,auxdata),maxwidth)) write() } } # End of loop to print groups. } # End of loop to print all items. returnend :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldprintf.icn
############################################################################## Name: printf.icn## Title: Printf-style formatting## Author: William H. Mitchell## Date: June 10, 1988############################################################################## # This procedure behaves somewhat like the standard printf.# Supports d, s, o, and x formats like printf. An "r" format# prints real numbers in a manner similar to that of printf's "f",# but will produce a result in an exponential format if the number# is larger than the largest integer plus one.# # Left or right justification and field width control are pro-# vided as in printf. %s and %r handle precision specifications.# # The %r format is quite a bit of a hack, but it meets the# author's requirements for accuracy and speed. Code contributions# for %f, %e, and %g formats that work like printf are welcome.# # Possible new formats:# # %t -- print a real number as a time in hh:mm# %R -- roman numerals# %w -- integers in english# %b -- binary# # ############################################################################procedure sprintf(format, a, b, c, d, e, f, g, h) local args args := [a,b,c,d,e,f,g,h] return _doprnt(format, args)endprocedure fprintf(file, format, a, b, c, d, e, f, g, h) local args args := [a,b,c,d,e,f,g,h] writes(file, _doprnt(format, args)) returnendprocedure printf(format, a, b, c, d, e, f, g, h) local args args := [a,b,c,d,e,f,g,h] writes(&output, _doprnt(format, args)) returnendprocedure _doprnt(format, args) local out, v, just, width, conv, prec, pad out := "" format ? repeat { (out ||:= tab(upto('%'))) | (out ||:= tab(0) & break) v := get(args) move(1) just := right width := conv := prec := pad := &null ="-" & just := left width := tab(many(&digits)) (\width)[1] == "0" & pad := "0" ="." & prec := tab(many(&digits)) conv := move(1) #write("just: ",image(just),", width: ", width, ", prec: ", # prec, ", conv: ", conv) case conv of { "d": { v := string(v) } "s": { v := string(v[1:(\prec+1)|0]) } "x": v := hexstr(v) "o": v := octstr(v) "i": v := image(v) "r": v := fixnum(v,prec) default: { push(args, v) v := conv } } if \width & *v < width then { v := just(v, width, pad) } out ||:= v } return outendprocedure hexstr(n) local h, neg static BigNeg, hexdigs, hexfix initial { BigNeg := -2147483647-1 hexdigs := "0123456789abcdef" hexfix := "89abcdef" } n := integer(n) if n = BigNeg then return "80000000" h := "" if n < 0 then { n := -(BigNeg - n) neg := 1 } repeat { h := hexdigs[n%16+1]||h if (n /:= 16) = 0 then break } if \neg then { h := right(h,8,"0") h[1] := hexfix[h[1]+1] } return hendprocedure octstr(n) local h, neg static BigNeg, octdigs, octfix initial { BigNeg := -2147483647-1 octdigs := "01234567" octfix := "23" } n := integer(n) if n = BigNeg then return "20000000000" h := "" if n < 0 then { n := -(BigNeg - n) neg := 1 } repeat { h := octdigs[n%8+1]||h if (n /:= 8) = 0 then break } if \neg then { h := right(h,11,"0") h[1] := octfix[h[1]+1] } return hendprocedure fixnum(x, prec) local int, frac, f1, f2, p10 /prec := 6 int := integer(x) | return image(x) frac := image(x - int) if find("e", frac) then { frac ?:= { f1 := tab(upto('.')) & move(1) & f2 := tab(upto('e')) & move(1) & p10 := -integer(tab(0)) & repl("0",p10-1) || f1 || f2 } } else frac ?:= (tab(upto('.')) & move(1) & tab(0)) frac := left(frac, prec, "0") return int || "." || fracend :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldradcon.icn
############################################################################## Name: radcon.icn## Title: Radix conversion## Author: Ralph E. Griswold## Date: June 10, 1988############################################################################## # The following procedures convert numbers from one radix to# another. The letters from a to z are used for ``digits'' greater# than 9. All the conversion procedures fail if the conversion can-# not be made.# # exbase10(i,j) convert base-10 integer i to base j# # inbase10(s,i) convert base-i integer s to base 10# # radcon(s,i,j) convert base-i integer s to base j# # Limitation:## The maximum base allowed is 36.# ############################################################################procedure exbase10(i,j) static digits local s, d, sign initial digits := &digits || &lcase if i = 0 then return 0 if i < 0 then { sign := "-" i := -i } else sign := "" s := "" while i > 0 do { d := i % j if d > 9 then d := digits[d + 1] s := d || s i /:= j } return sign || sendprocedure inbase10(s,i) if s[1] == "-" then return "-" || integer(i || "r" || s[2:0]) else return integer(i || "r" || s)endprocedure radcon(s,i,j) return exbase10(inbase10(s,i),j)end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldrational.icn
############################################################################## Name: rational.icn## Title: Perform arithmetic on rational numbers## Author: Ralph E. Griswold## Date: May 11, 1989############################################################################### These procedures perform arithmetic on rational numbers (fractions):## str2rst(s) Convert the string representation of a rational number# (such as "3/2") to a rational number.## rat2str(r) Convert the rational number r to its string# representation.## addrat(r1,r2) Add rational numbers r1 and r2.## subrat(r1,r2) Subtract rational numbers r1 and r2.## mpyrat(r1,r2) Multiply rational numbers r1 and r2.## divrat(r1,r2) Divide rational numbers r1 and r2.## negrat(r) Produce negative of rational number r.## reciprat(r) Produce the reciprocal of rational number r.# ############################################################################## Links: gcd#############################################################################link gcdrecord rational(numer,denom,sign)procedure str2rat(s) local div, numer, denom, sign s ? { ="[" & numer := integer(tab(upto('/'))) & move(1) & denom := integer(tab(upto(']'))) & pos(-1) } | fail div := gcd(numer,denom) | fail numer /:= div denom /:= div if numer * denom >= 0 then sign := 1 # dangerous -- potential overflow else sign := -1 return rational(abs(numer),abs(denom),sign)end procedure rat2str(r) return "[" || r.numer * r.sign || "/" || r.denom || "]"end procedure mpyrat(r1,r2) local numer, denom, div numer := r1.numer * r2.numer denom := r1.denom * r2.denom div := gcd(numer,denom) | fail # shouldn't fail return rational(numer / div,denom / div, r1.sign * r2.sign)endprocedure divrat(r1,r2) return mpyrat(r1,reciprat(r2)) # may failendprocedure reciprat(r) if r.numer = 0 then fail else return rational(r.denom,r.numer,r.sign)endprocedure negrat(r) return rational(r.numer,r.denom,-r.sign)endprocedure addrat(r1,r2) local denom, numer, div, sign denom := r1.denom * r2.denom numer := r1.sign * r1.numer * r2.denom + r2.sign * r2.numer * r1.denom if numer >= 0 then sign := 1 else sign := -1 div := gcd(numer,denom) | fail return rational(abs(numer / div),abs(denom / div),sign)endprocedure subrat(r1,r2) return addrat(r1,negrat(r2))end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldsegment.icn
############################################################################## Name: segment.icn## Title: Segment string## Author: William H. Mitchell## Date: June 10, 1988############################################################################## # These procedures segment a string s into consecutive substrings# consisting of characters that respectively do/do not occur in c.# segment(s,c) generates the substrings, while seglist produces a list# of the segments. For example,# # segment("Not a sentence.",&letters)# # generates# # "Not"# " "# "a"# " "# "sentence"# "."# while# seglist("Not a sentence.",&letters)## produces## ["Not"," ","a","sentence","."]#############################################################################procedure segment(line,dlms) local ndlms dlms := (any(dlms,line[1]) & ~dlms) ndlms := ~dlms line ? repeat { suspend tab(many(ndlms)) \ 1 suspend tab(many(dlms)) \ 1 pos(0) & break }endprocedure seglist(s,c) local a L := [] c := (any(c,s[1]) & ~c) s ? while put(L,tab(many(c := ~c))) return Lend :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldseqimage.icn
############################################################################## Name: seqimage.icn## Title: Produce string image of Icon result sequence## Author: Ralph E. Griswold## Date: June8############################################################################## # The procedure Seqimage{e,i,j} produces a string image of the# result sequence for the expression e. The first i results are# printed. If i is omitted, there is no limit. If there are more# than i results for e, ellipses are provided in the image after# the first i. If j is specified, at most j results from the end# of the sequence are printed after the ellipses. If j is omitted,# only the first i results are produced.# # For example, the expressions# # Seqimage{1 to 12}# Seqimage{1 to 12,10}# Seqimage{1 to 12,6,3}# # produce, respectively,# # {1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12}# {1, 2, 3, 4, 5, 6, 7, 8, 9, 10, ...}# {1, 2, 3, 4, 5, 6, ..., 10, 11, 12}# # # Warning:## If j is not omitted and e has a infinite result# sequence, Seqimage does not terminate.# ############################################################################procedure Seqimage(L) local seq, result, i, j, resid seq := "" i := @L[2] j := @L[3] while result := image(@L[1]) do if *L[1] > \i then { if /j then { seq ||:= ", ..." break } else { resid := [", " || result] every put(resid,", " || image(|@L[1])) if *resid > j then seq ||:= ", ..." every seq ||:= resid[*resid -j + 1 to *resid] } } else seq ||:= ", " || result return "{" || seq[3:0] || "}" | "{}"end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldshquote.icn
############################################################################## Name: shquote.icn## Title: Quote word for shells## Author: Robert J. Alexander## Date: December 5, 1989############################################################################### cshquote(s) -- Produces a version of s which is properly quoted# for the c-shell (csh).## mpwquote(s) -- Produces a version of s which is properly quoted# for the Macintosh Programmer's Workshop shell (MPW Shell).## shquote(s) -- Produces a version of s which is properly quoted# for the Bourne shell (sh).#############################################################################procedure cshquote(s) local quotechar quotechar := '\t\n $"#&\'()*;<>?[\\`|~' if not upto(quotechar,s) then return s s ? { s := "'" while s ||:= tab(find("'")) || "'\\''" & move(1) s ||:= tab(0) || "'" } return sendprocedure mpwquote(s) local quotechar,q quotechar := ' \t\n\r\0#;&|()k\'"/\\{}`?w[]+*./r<>r.d' if not upto(quotechar,s) then return s q := "" s ? { while (q ||:= tab(upto('\'')) || "'k''") & move(1) q ||:= tab(0) } return "'" || q || "'"endprocedure shquote(s) local quotechar quotechar := '\t\n\r $"#&\'()*;<>?\\^`|' if not upto(quotechar,s) then return s s ? { s := "'" while s ||:= tab(find("'")) || "'\\''" & move(1) s ||:= tab(0) || "'" } return s end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldshuffle.icn
############################################################################## Name: shuffle.icn## Title: Shuffle values## Author: Ward Cunningham and Ralph E. Griswold## Date: February 22, 1990############################################################################## # The procedure shuffle(x) shuffles a string or list. In the case# that x is a string, a corresponding string with the characters# randomly rearranged is produced. In the case that x is a list,# the values in the list are randomly rearranged.# ############################################################################procedure shuffle(x) local i x := string(x) # may fail every i := *x to 2 by -1 do x[?i] :=: x[i] return xend# Note: the following procedure is simpler, but does not produce# as good a shuffle:##procedure shuffle(x)# x := string(x)# every !x :=: ?x# return x#end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldsnapshot.icn
############################################################################## Name: snapshot.icn## Title: Show snapshot of Icon string scanning## Author: Ralph E. Griswold and Randal L. Schwartz## Date: June 10, 1988############################################################################## # The procedure snapshot() writes a snapshot of the state of string# scanning, showing the value of &subject and &pos. For example,# # "((a+b)-delta)/(c*d))" ? {# tab(bal('+-/*'))# snapshot()# }# # produces## -------------------------------------# | |# | &subject = "((a+b)-delta)/(c*d))" |# | | |# -------------------------------------# # Note that the bar showing the &pos is positioned under the &posth# character (actual positions are between characters). If &pos is# at the end of &subject, the bar is positioned under the quotation# mark delimiting the subject. For example,# # "abcdefgh" ? (tab(0) & snapshot())# # produces## -------------------------# | |# | &subject = "abcdefgh" |# | | |# -------------------------# # Escape sequences are handled properly. For example,# # "abc\tdef\nghi" ? (tab(upto('\n')) & snapshot())# # produces## ------------------------------# | |# | &subject = "abc\tdef\nghi" |# | | |# ------------------------------# ############################################################################procedure snapshot() local bar, bar2, is, is0, prefix prefix := "&subject = " is := image(&subject) is0 := *image(&subject[1:&pos]) | fail # quick exit if bogus write(bar := repl("-", *is + *prefix + 4)) # 4 = two vbars/two spaces write(bar2 := ("|" || repl(" ", *is + *prefix + 2) || "|")) write("| ", prefix, is, " |") bar2[*prefix + is0 + 2] := "|" # 2 = "| " prefix write(bar2) write(bar) return ""end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldstrings.icn
############################################################################## Name: strings.icn## Title: String utilities## Author: Ralph E. Griswold## Date: May 26, 1989############################################################################## # These procedures perform simple operations on strings.# # compress(s,c) Compress consecutive occurrences of charac-# ters in c that occur in s.# # omit(s,c) Omit all occurrences of characters in c# that occur in s.## replace(s1,s2,s3) In s1, replace all occurrences of s2 by s3.# # rotate(s,i) Rotate s i characters to the left (negative i# produces rotation to the right); the default# value of i is 1.# ############################################################################procedure compress(s,c) local result, s1 result := "" s ? { while result ||:= tab(upto(c)) do { result ||:= (s1 := move(1)) tab(many(s1)) } return result || tab(0) }end# omit characters#procedure omit(s,c) local result, s1 result := "" s ? { while result ||:= tab(upto(c)) do { s1 := move(1) tab(many(s1)) } return result || tab(0) }end# replace string#procedure replace(s1,s2,s3) local result, i result := "" i := *s2 s1 ? { while result ||:= tab(find(s2)) do { result ||:= s3 move(i) } return result || tab(0) }end# rotate string#procedure rotate(s,i) /i := 1 if i <= 0 then i +:= *s i %:= *s return s[i + 1:0] || s[1:i + 1]end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldstructs.icn
############################################################################## Name: structs.icn## Title: Structure operations## Author: Ralph E. Griswold## Date: June 10, 1988############################################################################## # These procedures manipulate structures.# # depth(t) compute maximum depth of tree t# # eq(x,y) compare list structures x and y## teq(t1,t2) compare trees t1 and t2# # equiv(s,y) compare arbitrary structures x and y# # ldag(s) construct a dag from the string s# # ltree(s) construct a tree from the string s# # stree(t) construct a string from the tree t# # tcopy(t) copy tree t# # visit(t) visit, in preorder, the nodes of the tree t# # The procedure equiv() tests for the "equivalence" of two values. For types# other than structures, it does the same thing as x1 === x2. For structures,# the test is for "shape". For example,## equiv([],[])## succeeds.## It handles loops, but does not recognize them as such. For example,# given## L1 := []# L2 := []# put(L1,L1)# put(L2,L1)## equiv(L1,L2)## succeeds.## The concept of equivalence for tables and sets is not quite right# if their elements are themselves structures. The problem is that there# is no concept of order for tables and sets, yet it is impractical to# test for equivalence of their elements without imposing an order. Since# structures sort by "age", there may be a mismatch between equivalent# structures in two tables or sets.## Note:# The procedures equiv and ldag have a trailing argument that is used on# internal recursive calls; a second argument must not be supplied# by the user.# ############################################################################procedure eq(x,y) local i if x === y then return y if type(x) == type(y) == "list" then { if *x ~= *y then fail every i := 1 to *x do if not eq(x[i],y[i]) then fail return y }endprocedure depth(ltree) local count count := 0 every count <:= 1 + depth(ltree[2 to *ltree]) return countendprocedure ldag(stree,done) local L /done := table() if L := \done[stree] then return L stree ? if L := [tab(upto('('))] then { move(1) while put(L,ldag(tab(bal(',)')),done)) do move(1) } else L := [tab(0)] return done[stree] := Lendprocedure ltree(stree) local L stree ? if L := [tab(upto('('))] then { move(1) while put(L,ltree(tab(bal(',)')))) do move(1) } else L := [tab(0)] return Lendprocedure stree(ltree) local s if *ltree = 1 then return ltree[1] s := ltree[1] || "(" every s ||:= stree(ltree[2 to *ltree]) || "," return s[1:-1] || ")"endprocedure tcopy(ltree) local L L := [ltree[1]] every put(L,tcopy(ltree[2 to *ltree])) return Lendprocedure teq(L1,L2) local i if *L1 ~= *L2 then fail if L1[1] ~== L2[1] then fail every i := 2 to *L1 do if not teq(L1[i],L2[i]) then fail return L2endprocedure visit(ltree) suspend ltree | visit(ltree[2 to *ltree])end procedure equiv(x1,x2,done) local code, i if x1 === x2 then return x2 # Covers everything but structures. if type(x1) ~== type(x2) then fail # Must be same type. if type(x1) == ("procedure" | "file") then fail # Leave only those with sizes (null # taken care of by first two tests). if *x1 ~= *x2 then fail # Skip a lot of possibly useless work. # Structures (and others) remain. /done := table() # Basic call. (/done[x1] := set()) | # Make set of equivalences if new. (if member(done[x1],x2) then return x2) # Records complicate things. image(x1) ? (code := (="record" | type(x1))) case code of { "list" | "record": every i := 1 to *x1 do if not equiv(x1[i],x2[i],done) then fail "table": if not equiv(sort(x1,3),sort(x2,3),done) then fail "set": if not equiv(sort(x1),sort(x2),done) then fail default: fail # Vaues of other types are different. } insert(done[x1],x2) # Equivalent; add to set. 2end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs FoldTranslate
For File In ≈.icn icont -c "{File}"End :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldtuple.icn
############################################################################## Name: tuple.icn## Title: Process n-tuples## Author: William H. Mitchell## Date: June 10, 1988############################################################################### This procedure implements a "tuple" feature that produces the effect# of multiple keys. A tuple is created by an expression of the# form## tuple([exrp1, expr2, ..., exprn])## The result can be used in a case expression or as a table subscript.# Lookup is successful provided the values of expr1, expr2, ..., exprn# are the same (even if the lists containing them are not). For example,# consider selecting an operation based on the types of two operands. The# expression## case [type(op1), type(op2)] of {# ["integer", "integer"]: op1 + op2# ["string", "integer"] : op1 || "+" || op2# ["integer", "string"] : op1 || "+" || op2# ["string", "string"] : op1 || "+" || op2# }## does not work, because the comparison in the case clauses compares lists# values, which cannot be the same as control expression, because the lists# are different, even though their contents are the same. With tuples,# however, the comparison succeeds, as in## case tuple([type(op1), type(op2)]) of {# tuple(["integer", "integer"]): op1 + op2# tuple(["string", "integer"]) : op1 || "+" || op2# tuple(["integer", "string"]) : op1 || "+" || op2# tuple(["string", "string"]) : op1 || "+" || op2# }#############################################################################procedure tuple(tl) static tuptab initial tuptab := table() # create the root node /tuptab[*tl] := table() # if there is no table for this size, make one tb := tuptab[*tl] # go to tuple for size of table i := 0 # assign default value to i every i := 1 to *tl - 1 do { # iterate though all but last value e := tl[i] # ith value in tuple /tb[e] := table() # if it is not in the table, make a new one tb := tb[e] # go to table for that value } le := tl[i + 1] # last value in tuple /tb[le] := copy(tl) # if it is new, entr a copy of the list return tb[le] # return the copy; it is uniqueend :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldusage.icn
############################################################################## Name: usage.icn## Title: Service procedures## Author: Ralph E. Griswold## Date: May 11, 1989############################################################################### These procedures provide various common services:## Usage(s) stops executions with a message concerning the# expected form of usage of a program.## ErrorCheck(l,f) reports an error that has been converted to# failure.## Feature(s) succeeds if feature s is available in the running# implementation of Icon.## Requires(s) terminates execution is feature s is not available.## Signature() writes the version, host, and features support in# the running implementation of Icon.#############################################################################procedure Usage(s) stop("Usage: ",s)endprocedure ErrorCheck(line,file) if &errortext == "" then fail # No converted error write("\nError ",&errornumber," at line ",line, " in file ",file) write(&errortext) write("offending value: ",image(&errorvalue)) returnendprocedure Feature(s) if s == &features then return else failendprocedure Requires(s) if not(Feature(s)) then stop(s," required")endprocedure Signature() write(&version) write(&host) every write(&features)end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldwildcard.icn
############################################################################## Name: wildcard.icn## Title: UNIX-like Wild Card Pattern Matching Function## Author: Robert J. Alexander## Date: November 27, 1989############################################################################### wildcard(s1,s2,i,j) -- Generates the sequence of integer positions in# string s2 after strings which satisfy pattern s1 in s2[i:j], but fails# if there is no such position. s1 is a UNIX-like wild-card pattern# containing *, ?, and [...].############################################################################### Links: allof## Requires: co-expressions#############################################################################link allofglobal wild_elementprocedure wildcard(p,s,i,j) local plist,c,e,complement,chars,special,ch if /s := &subject then /i := &pos else /i := 1 ; /j := 0 # # Create a list of pattern elements. The list looks like: # # * --> "*" # ? --> "?" # [abc] --> 'abc' # abc --> "abc" # plist := [] p ? { while not pos(0) do { c := &null # # Put pattern element character(s) on list. # e := =("*" | "?") | (="[" & c := tab(find("]")) & move(1)) | tab(upto('*?[') | 0) # # If it's [abc], create a cset. Special notations: # # A-Z means all characters from A to Z inclusive. # ! (if first) means any character not among those specified. # - or ] (if first, or after initial !) means itself. # \c ? { complement := ="!" | &null special := '-]' e := '' while ch := tab(any(special)) do { e ++:= ch special --:= ch } while chars := tab(find("-")) do { move(1) e ++:= chars[1:-1] ++ &cset[ord(chars[-1]) + 1:ord(move(1)) + 2] } e ++:= tab(0) if \complement then e := ~e } put(plist,e) } } # # Do the pattern match. # suspend s[i:j] ? ( allof {wild_element := !plist, case wild_element of { "*": move(*&subject - &pos + 1 to 0 by -1) "?": move(1) default: { case type(wild_element) of { "cset": tab(any(wild_element)) default: =(wild_element) } } } } & i + &pos - 1)end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldwrap.icn
############################################################################## Name: wrap.icn## Title: Wrap lines of output for use with write()## Author: Robert J. Alexander## Date: December 5, 1989############################################################################### wrap(s,i) -- Facilitates accumulation of small strings into longer# output strings, outputting when the accumulated string would# exceed a specified length (e.g. outputting items in multiple# columns).## s -- string to accumulate# i -- width of desired output string## Wrap fails if the string s did not necessitate output of the buffered# output string; otherwise the output string is returned (which never# includes s).## s defaults to the empty string (""), causing nothing to be# accumulated; i defaults to 0, forcing output of any buffered string.# Note that calling wrap() with no arguments produces the buffer (if it# is not empty) and clears it.## Wrap does no output to files.### Here's how wrap is normally used:## wrap() # Initialize (not really necessary unless# # a previous use might have left stuff in# # the buffer).## every i := 1 to 100 do # Loop to process strings to output --# write(wrap(x[i],80)) # only writes when 80-char line filled.## write(wrap()) # Output what's in buffer -- only outputs# # if something to write.### wraps(s,i) -- Facilitates managing output of numerous small strings# so that they do not exceed a reasonable line length (e.g.# outputting items in multiple columns).## s -- string to accumulate# i -- maximum width of desired output string## If the string "s" did not necessitate a line-wrap, the string "s" is# returned. If a line-wrap is needed, "s", preceded by a new-line# character ("\n"), is returned.## "s" defaults to the empty string (""), causing nothing to be# accumulated; i defaults to 0, forcing a new line if anything had been# output on the current line. Thus calling wraps() with no arguments# reinitializes it.## Wraps does no output to files.### Here's how wraps is normally used:## wraps() # Initialize (not really necessary unless# # a previous use might have left it in an# # unknown condition).## every i := 1 to 100 do # Loop to process strings to output --# writes(wraps(x[i],80))# only wraps when 80-char line filled.## writes(wraps()) # Only outputs "\n" if something written# # on last line.#############################################################################procedure wrap(s,i) local t static line initial line := "" /s := "" ; /i := 0 if *(t := line || s) > i then return "" ~== (s :=: line) line := tendprocedure wraps(s,i) local t static size initial size := 0 /s := "" ; /i := 0 t := size + *s if t > i & size > 0 then { size := *s return "\n" || s } size := t return send :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldximage.icn
############################################################################## Name: ximage.icn## Title: Produces "executable" image of structured data## Author: Robert J. Alexander## Date: December 5, 1989############################################################################### ximage() -- enhanced image()-type procedure that outputs all data# contained in structured types. It is called as follows:## ximage(x)## just like image(x) (the other arguments in the "procedure"# declaration are used for passing data among recursive levels). The# output has an "executable" appearance, which will look familiar to# any Icon programmer. The returned string for complex data contains# newline characters and indentation, suitable for write()-ing,# providing a pleasing and useful visual representation of the# structures.#############################################################################procedure ximage(x,indent,done) local i,s,ss,state,t,xtag static tag,tr # # If this is the outer invocation, do some initialization. # if /(state := done) then { tr := &trace ; &trace := 0 # postpone tracing while in here indent := "" tag := 0 done := table() } # # Determine the type and process accordingly. # indent := (if indent == "" then "\n" else "") || indent || " " ss := "" t := type(x) s := if xtag := \done[x] then xtag else case t of { # # Unstructured types just return their image(). # "null" | "string" | "integer" | "real" | "cset" | "co-expression" | "file" | "procedure" | "external": image(x) # # List. # "list": { done[x] := xtag := "L" || (tag +:= 1) # # Figure out if there is a predominance of any object in the # list. If so, make it the default object. # t := table(0) every t[!x] +:= 1 s := [,0] every t := !sort(t) do if s[2] < t[2] then s := t if s[2] > *x / 3 & s[2] > 2 then { s := s[1] t := ximage(s,indent || " ",done) if t ? (not any('\'"') & ss := tab(find(" :="))) then t := "{" || t || indent || " " || ss || "}" } else t := &null # # Output the non-defaulted elements of the list. # ss := "" every i := 1 to *x do if x[i] ~=== s then { ss ||:= indent || xtag || "[" || i || "] := " || ximage(x[i],indent,done) } s := image(x) s[-1:-1] := "," || \t xtag || " := " || s || ss } # # Set. # "set": { done[x] := xtag := "S" || (tag +:= 1) every i := !sort(x) do { ss ||:= indent || "insert(" || xtag || "," || ximage(i,indent,done,) || ")" } xtag || " := " || "set()" || ss } # # Table. # "table": { done[x] := xtag := "T" || (tag +:= 1) # # Output the table elements. This is a bit tricky, since # the subscripts might be structured, too. # every i := !sort(x) do { t := ximage(i[1],indent || " ",done) if t ? (not any('\'"') & s := tab(find(" :="))) then t := "{" || t || indent || " " || s || "}" ss ||:= indent || xtag || "[" || t || "] := " || ximage(i[2],indent,done) } # # Output the table, including its default value (which might # also be structured. # t := ximage(x[[]],indent || " ",done) if t ? (not any('\'"') & s := tab(find(" :="))) then t := "{" || t || indent || " " || s || "}" xtag || " := " || "table(" || t || ")" || ss } # # Record. # default: { done[x] := xtag := "R" || (tag +:= 1) every i := 1 to *x do { ss ||:= indent || xtag || "[" || i || "] := " || ximage(\x[i],indent,done) } xtag || " := " || t || "()" || ss } } # # If this is the outer invocation, clean up before returning. # if /state then { &trace := tr # restore &trace } # # Return the result. # return send :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldprogs:animal.icn
############################################################################## Name: animal.icn## Title: Animal game## Author: Robert J. Alexander## Date: June 10, 1988############################################################################## # This is the familiar ``animal game'' written in Icon. The# program asks its human opponent questions in an attempt to guess# what animal he is thinking of. It is an ``expert system'' that# starts out with limited knowledge, but gets smarter as it plays# and learns from its opponents. At the conclusion of a session,# the program asks permission to remember for future sessions that# which it learned.# # The game is not limited to guessing animals only. By simply# modifying the first two lines of procedure "main" it will happily# guess things in other categories. For example, the lines:# # GameObject := "president"# Tree := Question("Has he ever been known as Bonzo",# "Reagan","Lincoln")# # can be substituted and it works reasonably well. The knowledge# files will be kept separate, too.# # Typing list at any yes/no prompt will show an inventory of# animals known, and there are some other commands (see procedure# Confirm).# ############################################################################global GameObject,Tree,ShowLine,Learnrecord Question(question,yes,no)procedure main() GameObject := "animal" Tree := Question("Does it live in water","goldfish","canary") Get() # Recall prior knowledge Game() # Play a game returnendprocedure Game() while Confirm("Are you thinking of ",Article(GameObject)," ", GameObject) do { Ask(Tree) } write("Thanks for a great game.") if \Learn & Confirm("Want to save knowledge learned this session") then Save() returnendprocedure Confirm(q1,q2,q3,q4,q5,q6) local answer,s static ok initial { ok := table() ok["y"] := ok["yes"] := ok["yeah"] := ok["uh huh"] := "yes" ok["n"] := ok["no"] := ok["nope"] := ok["uh uh"] := "no" } while /answer do { write(q1,q2,q3,q4,q5,q6,"?") case s := read() | exit(1) of { "save": Save() "get": Get() "list": List() "dump": Output(Tree,&output) default: { (answer := \ok[map(s,&ucase,&lcase)]) | write("This is a \"yes\" or \"no\" question.") } } } return answer == "yes"endprocedure Ask(node) local guess,question case type(node) of { "string": { if not Confirm("It must be ",Article(node)," ",node,", right") then { Learn := "yes" write("What were you thinking of?") guess := read() | exit(1) write("What question would distinguish ",Article(guess)," ", guess," from ",Article(node)," ",node,"?") question := read() | exit(1) if question[-1] == "?" then question[-1] := "" question[1] := map(question[1],&lcase,&ucase) if Confirm("For ",Article(guess)," ",guess,", what would the _ answer be") then { return Question(question,guess,node) } else { return Question(question,node,guess) } } } "Question": { if Confirm(node.question) then { node.yes := Ask(node.yes) } else { node.no := Ask(node.no) } } }endprocedure Article(word) return if any('aeiouAEIOU',word) then "an" else "a"endprocedure Save() local f f := open(GameObject || "s","w") Output(Tree,f) close(f) returnendprocedure Output(node,f,sense) static indent initial indent := 0 /sense := " " case type(node) of { "string": write(f,repl(" ",indent),sense,"A: ",node) "Question": { write(f,repl(" ",indent),sense,"Q: ", node.question) indent +:= 1 Output(node.yes,f,"y") Output(node.no,f,"n") indent -:= 1 } } returnendprocedure Get() local f f := open(GameObject || "s","r") | fail Tree := Input(f) close(f) returnendprocedure Input(f) local nodetype,s read(f) ? (tab(upto(~' \t')) & =("y" | "n" | "") & nodetype := move(1) & move(2) & s := tab(0)) if nodetype == "Q" then { return Question(s,Input(f),Input(f)) } else { return s }endprocedure List() ShowLine := "" Show(Tree) write(trim(ShowLine)) returnendprocedure Show(node) if type(node) == "Question" then { Show(node.yes) Show(node.no) } else { if *ShowLine + *node > 78 then { write(trim(ShowLine)) ShowLine := "" } ShowLine ||:= node || " " } returnend :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldcalc.icn
############################################################################## Name: calc.icn## Title: Desk calculator## Author: Ralph E. Griswold## Date: February 22, 1990############################################################################### This is a simple Polish "desk calculator". It accepts as values Icon# integers, reals, csets, and strings (as they would appear in an Icon# program). Other lines of input are interpreted as operations. These# may be Icon operators, functions, or the special instructions listed# below.## In the case of operator symbols, such as +, that correspond to both unary# and binary operations, the binary one is used. Thus, the unary operation# is not available.## In case of Icon functions like write() that take an arbitrary number of# arguments, one argument is used.## The special instructions are:## clear remove all values from the calculator's stack# dump write out the contents of the stack# print print the top value on the stack, but do not remove it# quit exit the calculator## Example: the input lines## "abc"# 3# repl# print## prints "abcabcabc" and leaves this the only value on the stack.## Failure and most errors are detected, but in these case, arguments are# consumed and not restored to the stack.#############################################################################global stackprocedure main() local line, p, n, arglist stack := [] while line := read() do { push(stack,value(line)) | { # if it's a value, push it case line of { # else check special operations "clear": {stack := []; next} "dump": {every write(image(!stack)); next} "print": {write(image(stack[1])); next} "quit": exit() } if p := proc(line,3 | 2 | 1) then { # check for procedure n := abs(args(p)) arglist := [] every 1 to n do push(arglist,pop(stack)) | { write(&errout,"*** not enough arguments ***") break next } &error := 1 # anticipate possible error push(stack,p!arglist) | { if &error = 0 then { write(&errout,"*** error performing ",line) } else write(&errout,"*** failure performing ",line) } } else write(&errout,"*** invalid input: ",line) } }end# Check input to see if it's a value#procedure value(s) local n if n := numeric(s) then return n else { s ? { if ="\"" & s := tab(-1) & ="\"" then return escape(s) else if ="'" & s := tab(-1) & ="'" then return cset(escape(s)) else fail } }end# Handling escape sequences is no fun#procedure escape(s) local ns, c ns := "" s ? { while ns ||:= tab(upto('\\')) do { move(1) ns ||:= case c := map(move(1 | 0)) of { # can be either case "b": "\b" "d": "\d" "e": "\e" "f": "\f" "l": "\n" "n": "\n" "r": "\r" "t": "\t" "v": "\v" "'": "'" "\"": "\"" "x": hexcode() "^": ctrlcode() !"01234567": octcode() default: c } } ns ||:= tab(0) } return nsendprocedure hexcode() local i, s static cdigs initial cdigs := ~'0123456789ABCDEFabcdef' move(i := 2 | 1) ? s := tab(upto(cdigs) | 0) move(*s - i) return char("16r" || s)endprocedure octcode() local i, s static cdigs initial cdigs := ~'01234567' move(-1) move(i := 3 | 2 | 1) ? s := tab(upto(cdigs) | 0) move(*s - i) if s > 377 then { # back off if too large s := s[1:3] move(-1) } return char("8r" || s)endprocedure ctrlcode(s) return char(upto(map(move(1)),&lcase))end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldcolm.icn
############################################################################## Name: colm.icn## Title: Arrange data into columns## Author: Robert J. Alexander## Date: December 5, 1989############################################################################### Colm -- Arrange data into columns.## Program to arrange a number of data items, one per line, into# multiple columns. Items are arranged in column-wise order, that is,# the sequence runs down the first column, then down the second, etc.## If a null line appears in the input stream, it signifies a break in# the list, and the following line is taken as a title for the# following data items. No title precedes the initial sequence of# items.## Usage:## colm [-w line_width] [-s space_between] [-m min_width]# [-t tab_width] [-x] [-d] [file ...]## The parameters are:## line_width: the maximum width allowed for output lines# (default: 80).# space_between: minimum number of spaces between items# (default: 2).# min_width: minimum width to be printed for each entry# (default: no minimum).# tab_width: tab width used to entab output lines.# (default: no tabs).# -x print items in row-wise order rather than# column-wise.# -d (distribute) distribute columns throughout available width.## The command "colm -h" generates "help" text.## This is a general utility, but it was written and tailored for a# specific purpose:## This utility was written to rearrange the file name list from the# Macintosh Programmer's Workshop "Files" command into a more# convenient format. "Files" lists file names in a single column.# This program takes the list produced by "Files" and outputs a# multi-column list. The names are listed vertically within each# column, and the column width is computed dynamically depending upon# the sizes of the names listed. A recommendation is to create a# command file "lc" (List in Columns) as follows:## Files {"Parameters"} | colm## The output from the Files command is "piped" to the "colm" program# (this program), which prints its list in the current window.## By putting both the "lc" command file and the "colm" program into# your {MPW}Tools folder, "lc" can be conveniently issued as a command# at any time, using the same parameters as the "Files" command.link options, colmizeprocedure main(arg) local usage, help, opt, rowwise, distribute, maxcols, space, minwidth local tabwidth, f, entries, entry # # Define usage and help strings. # usage := "_ Usage:\tcolm [-w line_width] [-s space_between] [-m min_width]\n_ \t\t[-t tab_width] [-x] [file ...]\n_ \tcolm -h for help" help := "_ \tline_width:\tthe maximum width allowed for output lines\n_ \t\t\t(default: 80).\n_ \tspace_between:\tminimum number of spaces between items\n_ \t\t\t(default: 2).\n_ \tmin_width:\tminimum width to be printed for each entry\n_ \t\t\t(default: no minimum).\n_ \ttab_width:\ttab width used to print output lines.\n_ \t\t\t(default: no tabs).\n_ \t-x\t\tprint items in row-wise order rather than\n_ \t\t\tcolumn-wise.\n_ \t-d (distribute)\tdistribute columns throughout available width." # # Process command line options. # opt := options(arg,"hxdw+s+m+t+") if \opt["h"] then write(usage,"\n\n",help) & exit() rowwise := opt["x"] distribute := opt["d"] maxcols := \opt["w"] | 80 space := \opt["s"] | 2 minwidth := \opt["m"] | 0 tabwidth := (\opt["t"] | 0) + 1 if tabwidth = 1 then entab := 1 if *arg = 0 then arg := [&input] # # Loop to process input files. # while f := get(arg) do { f := (&input === f) | open(f) | stop("Can't open ",f) # # Loop to process input groups (separated by empty lines). # repeat { entries := [] # # Loop to build a list of non-empty lines of an input file. # while entry := "" ~== read(f) do { put(entries,entry) } # # Now write the data in columns. # every write(entab(colmize(entries,maxcols,space,minwidth, rowwise,distribute),tabwidth)) write("\n",read(f)) | break # print the title line, if any } close(f) write() }end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs FoldCompile
For File In ≈.icn icont "{File}"End :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldconcord.icn
############################################################################## Name: concord.icn## Title: Produce concordance## Author: Ralph E. Griswold## Date: December 22, 1989############################################################################### This program produces a simple concordance from standard input to standard# output. Words less than three characters long are ignored.## There are two options:## -l n set maximum line length to n (default 72), starts new line# -w n set maximum width for word to n (default 15), truncates## There are lots of possibilities for improving this program and adding# functionality to it. For example, a list of words to be ignored could be# provided. The formatting could be made more flexible, and so on.############################################################################### Note that the program is organized to make (via item()) to# handle other kinds of tabulations.############################################################################### Links: options#############################################################################link optionsglobal uses, colmax, namewidth, linenoprocedure main(args) local opts, uselist, name, line opts := options(args, "l+w+") # process options colmax := \opts["l"] | 72 namewidth := \opts["w"] | 15 uses := table("") lineno := 0 every tabulate(item(), lineno) # tabulate all the citations uselist := sort(uses, 3) # sort by uses while name := get(uselist) do format(left(name, namewidth) || get(uselist))end# Add line number to citations for name. If it already has been cited, # add (or increment) the number of citations.#procedure tabulate(name, lineno) local new, count, number lineno := string(lineno) new := "" uses[name] ? { while new ||:= tab(upto(&digits)) do { number := tab(many(&digits)) new ||:= number } if /number | (number ~== lineno) then uses[name] ||:= lineno || ", " # new line number else { if ="(" then count := tab(upto(')')) else count := 1 uses[name] := new || "(" || count + 1 || "), " } }end# Format the output, breaking long lines as necessary.#procedure format(line) local i while *line > colmax + 2 do { i := colmax + 2 until line[i -:= 1] == " " # back off to break point write(line[1:i]) line := repl(" ", namewidth) || line[i + 1:0] } write(line[1:-2])end# Get an item. Different kinds of concordances can be obtained by# modifying this procedure.#procedure item() local i, word, line while line := read() do { lineno +:= 1 write(right(lineno, 6), " ", line) line := map(line) # fold to lowercase i := 1 line ? { while tab(upto(&letters)) do { word := tab(many(&letters)) if *word >= 3 then suspend word # skip short words } } }end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldcross.icn
############################################################################## Name: cross.icn## Title: Display intersection of words## Author: William P. Malloy## Date: June 10, 1988############################################################################## # This program takes a list of words and tries to arrange them# in cross-word format so that they intersect. Uppercase letters# are mapped into lowercase letters on input. For example, the# input# # and# eggplants# elephants# purple# # produces the output# +---------+# | p |# | u e |# | r g |# | p g |# |elephants|# | e l |# | and |# | n |# | t |# | s |# +---------+# # Diagnostics: The program objects if the input contains a nonal-# phabetic character.# # Comments: This program produces only one possible intersection# and it does not attempt to produce the most compact result. The# program is not very fast, either. There is a lot of room for# improvement here. In particular, it is natural for Icon to gen-# erate a sequence of solutions.# ############################################################################global fast, place, array, csave, fsave, numberprocedure main() local words, nonletter, line nonletter := ~&letters words := [] while line := map(read()) do if upto(nonletter,line) then stop("input contains nonletter") else put(words,line) number := *words kross(words)endprocedure kross(words) local one, tst, t array := [get(words)] t := 0 while one := get(words) do { tst := *words if fit(one,array,0 | 1) then t := 0 else { t +:= 1 put(words,one) if t > tst then break } } if *words = 0 then Print(array) else write(&errout,"cannot construct puzzle")endprocedure fit(word,matrix,where) local i, j, k, l, one, test, t, s s := *matrix t := *matrix[1] every k := gen(*word) do every i := gen(s) do every j := gen(t) do if matrix[i][j] == word[k] then { # test for vertical fit if where = 0 then { test := 0 every l := (i - k + 1) to (i + (*word - k)) do if tstv(matrix,i,j,l,s,t) then { test := 1 break } if test = 0 then return putvert(matrix,word,i,j,k) } if where = 1 then { test := 0 every l := (j - k + 1) to (j + (*word - k)) do if tsth(matrix,i,j,l,s,t) then { test := 1 break } if test = 0 then return puthoriz(matrix,word,i,j,k) } }endprocedure tstv(matrix,i,j,l,s,t) return ((matrix[(l ~= i) & (s >= l) & (0 < l)][0 < j-1] ~== " ") | (matrix[(l ~= i) & (s >= l) & (0 < l)][t >= j + 1] ~== " ") | (matrix[(i ~= l-1) & (s >= l-1) & (0 < l-1)][j] ~== " ") | (matrix[(i ~= l + 1) & (s >= l+1) & (0 < l + 1)][j] ~== " ") | (matrix[(l ~= i) & (s >= l) & (0 < l)][j] ~== " "))endprocedure tsth(matrix,i,j,l,s,t) return ((matrix[0 < i-1][(l ~= j) & (t >= l) & (0 < l)] ~== " ") | (matrix[s >= i + 1][(l ~= j) & (t >= l) & (0 < l)] ~== " ") | (matrix[i][(j ~= l-1) & (t >= l-1) & (0 < l-1)] ~== " ") | (matrix[i][(j ~= l + 1) & (t >= l + 1) & (0 < l + 1)] ~== " ") | (matrix[i][(l ~= j) & (t >= l) & (0 < l)] ~== " "))endprocedure gen(i) local tmp, up, down tmp := i / 2 if (i % 2) = 1 then tmp +:= 1 suspend tmp up := tmp down := tmp while (up < i) do { suspend up +:= 1 suspend (down > 1) & (down -:= 1) }end# put `word' in vertically at pos(i,j)procedure putvert(matrix,word,i,j,k) local hdim, vdim, up, down, l, m, n vdim := *matrix hdim := *matrix[1] up := 0 down := 0 up := abs(0 > (i - k)) down := abs(0 > ((vdim - i) - (*word - k))) every m := 1 to up do push(matrix,repl(" ",hdim)) i +:= up every m := 1 to down do put(matrix,repl(" ",hdim)) every l := 1 to *word do matrix[i + l - k][j] := word[l] return matrixend# put `word' in horizontally at position i,j in matrixprocedure puthoriz(matrix,word,i,j,k) local hdim, vdim, left, right, l, m, n vdim := *matrix hdim := *matrix[1] left := 0 right := 0 left := (abs(0 > (j - k))) | 0 right := (abs(0 > ((hdim - j) - (*word - k)))) | 0 every m := 1 to left do every l := 1 to vdim do matrix[l] := " " || matrix[l] j +:= left every m := 1 to right do every l := 1 to vdim do matrix[l] ||:= " " every l := 1 to *word do matrix[i][j + l - k] := word[l] return matrixendprocedure Print(matrix) local i write("+",repl("-",*matrix[1]),"+") every i := 1 to *matrix do write("|",matrix[i],"|") write("+",repl("-",*matrix[1]),"+")end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldcsgen.icn
############################################################################## Name: csgen.icn## Title: Generate instances of sentences from context-sensitive grammars## Author: Ralph E. Griswold## Date: June 10, 1988############################################################################## # This program accepts a context-sensitive production grammar# and generates randomly selected sentences from the corresponding# language.# # Uppercase letters stand for nonterminal symbols and -> indi-# cates the lefthand side can be rewritten by the righthand side.# Other characters are considered to be terminal symbols. Lines# beginning with # are considered to be comments and are ignored.# A line consisting of a nonterminal symbol followed by a colon and# a nonnegative integer i is a generation specification for i# instances of sentences for the language defined by the nontermi-# nal (goal) symbol. An example of input to csgen is:# # # a(n)b(n)c(n)# # Salomaa, p. 11.# # Attributed to M. Soittola.# ## X->abc# X->aYbc# Yb->bY# Yc->Zbcc# bZ->Zb# aZ->aaY# aZ->aa# X:10# # The output of csgen for this example is# # aaabbbccc# aaaaaaaaabbbbbbbbbccccccccc# abc# aabbcc# aabbcc# aaabbbccc# aabbcc# abc# aaaabbbbcccc# aaabbbccc# # # A positive integer followed by a colon can be prefixed to a# production to replicate that production, making its selection# more likely. For example,# # 3:X->abc# # is equivalent to# # X->abc# X->abc# X->abc# # Option: The -t option writes a trace of the derivations to stan-# dard error output.# # Limitations: Nonterminal symbols can only be represented by sin-# gle uppercase letters, and there is no way to represent uppercase# letters as terminal symbols.# # There can be only one generation specification and it must# appear as the last line of input.# # Comments: Generation of context-sensitive strings is a slow pro-# cess. It may not terminate, either because of a loop in the# rewriting rules or because of the progressive accumulation of# nonterminal symbols. The program avoids deadlock, in which there# are no possible rewrites for a string in the derivation.# # This program would be improved if the specification of nonter-# minal symbols were more general, as in rsg.# ############################################################################## Links: options#############################################################################link optionsglobal xlistprocedure main(args) local line, goal, count, s, opts, deadlock opts := options(args,"x") deadlock := \opts["x"] while line := read() do # read in grammar if line[1] == "#" then next else if xpairs(line) then next else { line ? (goal := move(1),move(1),count := (0 < integer(tab(0)))) break } if /count then stop("no goal specification") every 1 to count do { # generate sentences s := goal while upto(&ucase,s) do { # test for nonterminal if \deadlock then write(&errout,s) # quit on deadlock if not(s ? replace(!xlist)) then break next until s ?:= replace(?xlist) # make replacement } write(s) }end# replace left hand side by right hand side#procedure replace(a) suspend tab(find(a[1])) || (move(*a[1]),a[2]) || tab(0)end# enter rewriting rule#procedure xpairs(s) local i, a initial xlist := [] if s ? { # handle optional replication factor i := 1(0 < integer(tab(upto(':'))),move(1)) | 1 & a := [tab(find("->")),(move(2),tab(0))] } then { every 1 to i do put(xlist,a) return }end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Folddeal.icn
############################################################################## Name: deal.icn## Title: Deal bridge hands## Author: Ralph E. Griswold## Date: June 10, 1988############################################################################## # This program shuffles, deals, and displays hands in the game# of bridge. An example of the output of deal is# ---------------------------------# # S: KQ987# H: 52# D: T94# C: T82# # S: 3 S: JT4# H: T7 H: J9863# D: AKQ762 D: J85# C: QJ94 C: K7# # S: A652# H: AKQ4# D: 3# C: A653# # ---------------------------------# # Options: The following options are available:# # -h n Produce n hands. The default is 1.# # -s n Set the seed for random generation to n. Different# seeds give different hands. The default seed is 0.# ############################################################################## Links: options, shuffle#############################################################################link options, shuffleglobal deck, deckimage, handsize, suitsize, denom, rank, blankerprocedure main(args) local hands, opts deck := deckimage := string(&letters) # initialize global variables handsize := suitsize := *deck / 4 rank := "AKQJT98765432" blanker := repl(" ",suitsize) denom := &lcase[1+:suitsize] opts := options(args,"h+s+") hands := \opts["h"] | 1 &random := \opts["s"] every 1 to hands do display()end# Display the hands#procedure display() local layout, i static bar, offset initial { bar := "\n" || repl("-",33) offset := repl(" ",10) } deck := shuffle(deck) layout := [] every push(layout,show(deck[(0 to 3) * handsize + 1 +: handsize])) write() every write(offset,!layout[1]) write() every i := 1 to 4 do write(left(layout[4][i],20),layout[2][i]) write() every write(offset,!layout[3]) write(bar)end# Put the hands in a form to display#procedure show(hand) static clubmap, diamondmap, heartmap, spademap initial { clubmap := denom || repl(blanker,3) diamondmap := blanker || denom || repl(blanker,2) heartmap := repl(blanker,2) || denom || blanker spademap := repl(blanker,3) || denom } return [ "S: " || arrange(hand,spademap), "H: " || arrange(hand,heartmap), "D: " || arrange(hand,diamondmap), "C: " || arrange(hand,clubmap) ]end# Arrange hands for presentation#procedure arrange(hand,suit) return map(map(hand,deckimage,suit) -- ' ',denom,rank)end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Folddelam.icn
############################################################################## Name: delam.icn## Title: Delaminate file## Author: Thomas R. Hicks## Date: June 10, 1988############################################################################## # This program delaminates standard input into several output# files according to the specified fields. It writes the fields in# each line to the corresponding output files as individual lines.# If no data occurs in the specified position for a given input# line an empty output line is written. This insures that all out-# put files contain the same number of lines as the input file.# # If - is used for the input file, the standard input is read.# If - is used as an output file name, the corresponding field is# written to the standard output.# # The fields are defined by a list of field specifications,# separated by commas or colons, of the following form:# # n the character in column n# n-m the characters in columns n through m# n+m m characters beginning at column n# # where the columns in a line are numbered from 1 to the length of# the line.# # The use of delam is illustrated by the following examples.# The command# # delam 1-10,5 x.txt y.txt# # reads standard input and writes characters 1 through 10 to file# x.txt and character 5 to file y.txt. The command# # delam 10+5:1-10:1-10:80 mid x1 x2 end# # writes characters 10 through 14 to mid, 1 through 10 to x1 and# x2, and character 80 to end. The command# # delam 1-80,1-80 - -# # copies standard input to standard output, replicating the first# eighty columns of each line twice.# ############################################################################## Links: usage#############################################################################link usageprocedure main(a) local fylist, ranges if any(&digits,a[1]) then ranges := fldecode(a[1]) else { write(&errout,"Bad argument to delam: ",a[1]) Usage("delam fieldlist {outputfile | -} ...") } if not a[2] then Usage("delam fieldlist {outputfile | -} ...") fylist := doutfyls(a,2) if *fylist ~= *ranges then stop("Unequal number of field args and output files") delamr(ranges,fylist)end# delamr - do actual division of input file#procedure delamr(ranges,fylist) local i, j, k, line while line := read() do { i := 1 while i <= *fylist do { j := ranges[i][1] k := ranges[i][2] if k > 0 then write(fylist[i][2],line[j+:k] | line[j:0] | "") i +:= 1 } }end# doutfyls - process the output file arguments; return list#procedure doutfyls(a,i) local lst, x lst := [] while \a[i] do { if x := llu(a[i],lst) then # already in list lst |||:= [[a[i],lst[x][2]]] else # not in list if a[i] == "-" then # standard out lst |||:= [[a[i],&output]] else # new file if not (x := open(a[i],"w")) then stop("Cannot open ",a[i]," for output") else lst |||:= [[a[i],x]] i +:= 1 } return lstend# fldecode - decode the fieldlist argument#procedure fldecode(fldlst) local fld, flst, poslst, m, n, x poslst := [] flst := str2lst(fldlst,':,') every fld := !flst do { if x := upto('-+',fld) then { if not (m := integer(fld[1:x])) then stop("bad argument in field list; ",fld) if not (n := integer(fld[x+1:0])) then stop("bad argument in field list; ",fld) if upto('-',fld) then { if n < m then n := 0 else n := (n - m) + 1 } } else { if not (m := integer(fld)) then stop("bad argument in field list; ",fld) n := 1 } poslst |||:= [[m,n]] } return poslstend# llu - lookup file name in output file list#procedure llu(str,lst) local i i := 1 while \lst[i] do { if \lst[i][1] == str then return i i +:= 1 }end# str2lst - create a list from a delimited string#procedure str2lst(str,delim) local lst, f lst := [] str ? { while f := (tab(upto(delim))) do { lst |||:= [f] move(1) } if "" ~== (f := tab(0)) then lst |||:= [f] } return lstend :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Folddelamc.icn
############################################################################## Name: delamc.icn## Title: Delaminate file using tab characters## Author: Thomas R. Hicks## Date: May 28, 1989############################################################################## # This program delaminates standard input into several output# files according to the separator characters specified by the# string following the -t option. It writes the fields in each# line to the corresponding output files as individual lines. If no# data occurs in the specified position for a given input line an# empty output line is written. This insures that all output files# contain the same number of lines as the input file.# # If - is used as an output file name, the corresponding field# is written to the standard output. If the -t option is not used,# an ascii horizontal tab character is assumed as the default field# separator.# # The use of delamc is illustrated by the following examples.# The command# # delamc labels opcodes operands# # writes the fields of standard input, each of which is separated# by a tab character, to the output files labels, opcodes, and# operands. The command# # delamc -t: scores names matric ps1 ps2 ps3# # writes the fields of standard input, each of which are separated# by a colon, to the indicated output files. The command# # delamc -t,: oldata f1 f2# # separates the fields using either a comma or a colon.# ############################################################################## Links: usage#############################################################################link usageprocedure main(a) local tabset, fylist, nxtarg if match("-t",a[1]) then { # tab char given tabset := cset(a[1][3:0]) pop(a) # get rid of that argument } if 0 = *(fylist := doutfyls(a)) then Usage("delamc [-tc] {outputfile | -} ...") /tabset := cset(&ascii[10]) # tab is default separator delamrc(tabset,fylist) # call main routineend# delamrc - do actual division of input file using tab chars#procedure delamrc(tabset,fylist) local i, flen, line while line := read() do { i := 1 flen := *fylist line ? while (i <= flen) do { if i = flen then write(fylist[i][2],tab(0) | "") else write(fylist[i][2],tab(upto(tabset)) | tab(0) | "") move(1) i +:= 1 } }end# doutfyls - process output file arguments; return list#procedure doutfyls(a) local lst, x, i lst := [] i := 1 while \a[i] do { if x := llu(a[i],lst) then # already in list lst |||:= [[a[i],lst[x][2]]] else # not in list if a[i] == "-" then # standard out lst |||:= [[a[i],&output]] else # a new file if not (x := open(a[i],"w")) then stop("Cannot open ",a[i]," for output") else lst |||:= [[a[i],x]] i +:= 1 } return lstend# llu - lookup file name in output file list#procedure llu(str,lst) local i i := 1 while \lst[i] do { if \lst[i][1] == str then return i i +:= 1 }end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Folddiffn.icn
############################################################################## Name: diffn.icn## Title: Show differences files## Author: Robert J. Alexander## Date: May 15, 1989############################################################################## # This program shows the differences between n files. Is is invoked as## diffn file1 file2 ... filen# ############################################################################## Links: dif#############################################################################link difglobal f1,f2record dfile(file,linenbr)procedure main(arg) local f, i, files, drec, status if *arg < 2 then stop("usage: diffn file file ...") f := list(*arg) every i := 1 to *arg do f[i] := dfile(open(arg[i]) | stop("Can't open ",arg[i]),0) files := list(*arg) every i := 1 to *arg do { write("File ",i,": ",arg[i]) files[i] := diff_proc(myread,f[i]) } every drec := dif(files) do { status := "diffs" write("==================================") every i := 1 to *drec do { write("---- File ",i,", ", (drec[i].pos > f[i].linenbr & "end of file") | "line " || drec[i].pos, " ---- (",arg[i],")") listrange(drec[i].diffs,drec[i].pos) } } if /status then write("==== Files match ====") returnendprocedure listrange(dlist,linenbr) local x every x := !dlist do { write(x); linenbr +:= 1 } returnendprocedure myread(x) return x.linenbr <- x.linenbr + 1 & read(x.file)end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Folddiffword.icn
############################################################################## Name: diffword.icn## Title: List different words## Author: Ralph E. Griswold## Date: May 9, 1989############################################################################### This program lists all the different words in the input text.# The definition of a "word" is naive.#############################################################################procedure main() local letter, words, text letter := &letters words := set() while text := read() do text ? while tab(upto(letter)) do insert(words,tab(many(letter))) every write(!sort(words))end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldedscript.icn
############################################################################## Name: edscript.icn## Title: Produce script for the ed editor## Author: Ralph E. Griswold## Date: June 10, 1988############################################################################## # This program takes specifications for global edits from standard# input and outputs an edit script for the UNIX editor ed to standard output.# Edscript is primarily useful for making complicated literal sub-# stitutions that involve characters that have syntactic meaning to# ed and hence are difficult to enter in ed.# # Each specification begins with a delimiter, followed by a tar-# get string, followed by the delimiter, followed by the replace-# ment string, followed by the delimiter. For example# # |...|**|# |****||# # specifies the replacement of all occurrences of three consecutive# periods by two asterisks, followed by the deletion of all# occurrences of four consecutive asterisks. Any character may be# used for the delimiter, but the same character must be used in# all three positions in any specification, and the delimiter char-# acter cannot be used in the target or replacement strings.# # Diagnostic:# # Any line that does not have proper delimiter structure is noted# and does not contribute to the edit script.# # Reference:# # "A Tutorial Introduction to the UNIX Text Editor", Brian W. Kernighan.# AT&T Bell Laboratories.# ############################################################################procedure main() local line, image, object, char while line := read() do { line ? { char := move(1) | {error(line); next} image := tab(find(char)) | {error(line); next} move(1) object := tab(find(char)) | {error(line); next} } write("g/",xform(image),"/s//",xform(object),"/g") } write("w\nq")end# process characters that have meaning to ed#procedure insert() static special initial special := '\\/^&*[.$' suspend { tab(upto(special)) || "\\" || move(1) || (insert() | tab(0)) }endprocedure error(line) write(&errout,"*** erroneous input: ",line)end# transform line#procedure xform(line) line ?:= insert() return lineend :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldempg.icn
############################################################################## Name: empg.icn## Title: Expression Measurement Program Generator## Author: Ralph E. Griswold## Date: March 8, 1990############################################################################### This program reads Icon expressions, one per line, and writes out# and Icon program, which when run, times the expressions and reports# average evaluation time and storage allocation.## Lines beginning with a # are treated as comments and written to the# output program so as to be written as comments when the output program is# run.## Lines beginning with a : are passed to the output program to be# evaluated, but not timed.## Lines beginning with a $ are included at the end of the output# program as declarations.## All other lines are timed in loops.## An example of input is:## :T := table(0)# $record complex(r,i)# T[1]# complex(0.0,0.0)## The resulting output program evaluates the expressions on the last two# lines and reports their average time and storage allocation.## Loop overhead for timing is computed first. The default number of# iterations s 10000. A different number can be given on the command line# when empg is executed, as in## iconx empg 1000 <test.exp >test.icn## which takes expressions from test.exp, computes loop overhead using 1000# iterations, and writes the measurement program to test.icn.## The default number of iterations for timing expressions is 1000. A# different number can be given on the command line when the measurement# program is run, as in## icont test# iconx test 5000## which times the expressions in test.icn using 5000 iterations.## If a garbage collection occurs during timing, the average time is# likely to be significantly distorted and average allocation cannot be# computed. In this case, the number of garbage collections is reported# instead. To avoid misleading results as a consequence, measurement# programs should be run with Icon's region sizes set to as large values# as possiavoid residual effects of one timed expression on# another, expressions that allocate significant amounts of storage# should be measured in separate programs.## The number of iterations used to compute loop overhead im empg# and the number of iterations used to time expressions in measurement# programs should be chosen so that the effects of low clock resolution# are minimized. In particular, systems with very fast CPUs but# low clock resolution (like 386 and 486 processors running under# MS-DOS) need large values.############################################################################### Links: numbers (in measurement programs, not in empg.icn)#############################################################################procedure main(argl) local i, decls, line, input i := integer(argl[1]) | 10000 decls := [] # list for declarations write("link numbers") write("global _Count, _Coll, _Store, _Overhead, _Names") write("procedure main(argl)") write(" _Iter := argl[1] | 1000") write(" _Names := [\"static\",\"string\",\"block \"]") write(" write(\"iterations: \",_Iter)") write(" write(\"&version: \",&version)") write(" write(\"&host: \",&host)") write(" write(\"&dateline: \",&dateline)") write(" write(\"region sizes: \")") write(" _I := 1") write(" every _S := ®ions do {") write(" write(\" \",_Names[_I],\" \",_S)") write(" _I +:= 1") write(" }") write(" _Count := ",i) write(" _Itime := &time") write(" every 1 to _Count do { &null }") write(" _Overhead := real(&time - _Itime) / _Count") write(" _Itime := &time") write(" every 1 to _Count do { &null & &null }") write(" _Overhead := real(&time - _Itime) / _Count - _Overhead") write(" _Count := _Iter") while line := read(input) do case line[1] of { ":": { # evaluate but do not time write(" ",line[2:0]) write(" write(",image(line[2:0]),")") } "$": { # line of declaration put(decls,line[2:0]) write(" write(",image(line[2:0]),")") } "#": # comment write(" write(",image(line),")") default: { # time in a loop write(" write(",image(line),")") write(" _Prologue()") write(" _Itime := &time") write(" every 1 to _Count do {") write(" &null & ", line) write(" }") write(" _Epilogue(&time - _Itime)") } } write("end") write("procedure _Prologue()") write(" _Store := []") write(" _Coll := []") write(" collect()") write(" every put(_Store,&storage)") write(" every put(_Coll,&collections)") write("end") write("procedure _Epilogue(_Time)") write(" every put(_Store,&storage)") write(" every put(_Coll,&collections)") write(" write(fix(real(_Time) / _Count - _Overhead,1,8),\" ms.\")") write(" if _Coll[1] = _Coll[5] then {") write(" write(\"average allocation:\",)") write(" every _I := 1 to 3 do") write(" write(\" \",_Names[_I],fix(real(_Store[_I + 3] - _Store[_I]),_Count,12))") write(" }") write(" else {") write(" write(\"garbage collections:\")") write(" write(\" total \",right(_Coll[5] - _Coll[1],4))") write(" every _I := 6 to 8 do write(\" \",_Names[_I - 5],right(_Coll[_I] - _Coll[_I - 4],4))") write(" }") write(" write()") write("end") every write(!decls) # write out declarationsend :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldfarb.icn
############################################################################## Name: farb.icn## Title: Generate Farberisms## Author: Ralph E. Griswold## Date: June 10, 1988############################################################################## # Dave Farber, co-author of the original SNOBOL programming# language, is noted for his creative use of the English language.# Hence the terms ``farberisms'' and ``to farberate''. This pro-# gram produces a randomly selected farberism.# # Notes: Not all of the farberisms contained in this program were# uttered by the master himself; others have learned to emulate# him. A few of the farberisms may be objectionable to some per-# sons. ``I wouldn't marry her with a twenty-foot pole.''# ############################################################################## Program note:## This program is organized into several procedures to avoid oveflowing# the default table sizes in the Icon translator and linker.#############################################################################procedure main(arg) local count &random := map(&clock,":","0") count := integer(arg[1]) | 1 every write(|??[farb1(),farb2(),farb3(),farb4()]) \ countendprocedure farb1() return [ "I enjoy his smiling continence.", "Picasso wasn't born in a day.", "I'll be there with spades on.", "Beware a Trojan bearing a horse.", "A hand in the bush is worth two anywhere else.", "All the lemmings are going home to roost.", "Anybody who marries her would stand out like a sore thumb.", "Before they made him they broke the mold.", "He's casting a red herring on the face of the water.", "Clean up or fly right.", "Come down off your charlie horse.", "Don't burn your bridges until you come to them.", "Don't count your chickens until the barn door is closed.", "Don't do anything I wouldn't do standing up in a hammock.", "Don't get your eye out of joint.", "Don't just stand there like a sitting duck.", "Don't look a mixed bag in the mouth.", "Don't look at me in that tone of voice.", "Don't make a molehill out of a can of beans.", "Don't make a tempest out of a teapot." ]endprocedure farb2() return [ "Don't upset the apple pie.", "Every cloud has a blue horizon.", "She's faster than the naked eye.", "Feather your den with somebody else's nest.", "From here on up, it's down hill all the way.", "Go fly your little red wagon somewhere else.", "Half a worm is better than none.", "He doesn't know which side his head is buttered on.", "He has feet of molasses.", "He hit the nose right on the head.", "He knows which side his pocketbook is buttered on.", "He smokes like a fish.", "He was hoisted by a skyhook on his own petard!", "He was putrified with fright.", "He would forget his head if it weren't screwed up.", "He's as happy as a pig at high tide.", "He's been living off his laurels for years.", "He's got a rat's nest by the tail.", "He's got four sheets in the wind.", "He's letting ground grow under his feet.", "He's lying through his britches.", "He's procrastinating like a bandit.", "He's reached the crescent of his success.", "He's so far above me I can't reach his bootstraps.", "He's too smart for his own bootstraps.", "His foot is in his mouth up to his ear.", "History is just a repetition of the past.", "I apologize on cringed knees.", "I don't know which dagger to clothe it in.", "I hear the handwriting on the wall.", "I wouldn't marry her with a twenty-foot pole.", "I'll procrastinate when I get around to it.", "I'm going to throw myself into the teeth of the gamut.", "I'm parked somewhere in the boondoggles." ]endprocedure farb3() return [ "I'm walking on cloud nine.", "I've got to put my duff to the grindstone.", "I've had it up to the hilt.", "If Calvin Coolidge were alive today, he'd turn over in his grave.", "If the onus fits, wear it.", "Is he an Amazon!", "It fills a well-needed gap.", "It is better to have tried and failed than never to have failed at all.", "It looks like it's going to go on ad infinitum for a while.", "It sounds like roses to my ears.", "It's a caterpillar in pig's clothing.", "It's a fiat accompli.", "It's a fool's paradise wrapped in sheep's clothing.", "It's a monkey wrench in your ointment.", "It's a new high in lows.", "It's bouncing like a greased pig.", "It's enough to make you want to rot your socks.", "It's like talking to a needle in a haystack.", "It's like trying to light a fire under a lead camel.", "It's not his bag of tea.", "It's so unbelieveable you wouldn't believe it.", "Just because it's there, you don't have to mount it.", "Keep your ear peeled!", "Let's not drag any more dead herrings across the garden path.", "Let's skin another can of worms.", "Look at the camera and say `bird'.", "Look before you turn the other cheek.", "Men, women, and children first!", "Necessity is the mother of strange bedfellows.", "Never feed a hungry dog an empty loaf of bread.", "No rocks grow on Charlie.", "No sooner said, the better.", "Nobody could fill his socks.", "Nobody is going to give you the world in a saucer.", "Nobody marches with the same drummer.", "Not by the foggiest stretch of the imagination!", "Not in a cocked hat, you don't!", "People in glass houses shouldn't call the kettle black.", "Put it on the back of the stove and let it simper." ]endprocedure farb4() return [ "Put the onus on the other foot.", "Rome wasn't built on good intentions alone.", "She has eyes like two holes in a burnt blanket.", "She's a virgin who has never been defoliated.", "She's trying to feather her own bush.", "Somebody's flubbing his dub.", "It's steel wool and a yard wide.", "Straighten up or fly right.", "Strange bedfellows flock together.", "That's a bird of a different color.", "That's a horse of a different feather.", "That's a sight for deaf ears.", "That's the way the old ball game bounces.", "The die has been cast on the face of the waters.", "The early bird will find his can of worms.", "The foot that rocks the cradle is usually in the mouth.", "The onus is on the other foot.", "The whole thing is a hairy potpourri.", "There are enough cooks in the pot already.", "There's a dark cloud on every rainbow's horizon.", "There's a flaw in the ointment.", "There's going to be hell and high water to pay.", "They don't stand a teabag's chance in hell.", "They sure dipsied his doodle.", "This ivory tower we're living in is a glass house.", "Time and tide strike but once." ]end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldfileprnt.icn
############################################################################## Name: fileprnt.icn## Title: Display representations of characters in file## Author: Ralph E. Griswold## Date: November 21, 1989############################################################################### This program reads the file specified as a command-line argument and# writes out a representation of each character in several forms:# hexadecimal, octal, decimal, symbolic, and ASCII code.## Inpupt is from a named file rather than standard input, so that it# can be opened in untranslated mode. Otherwise, on some systems, input# is terminated for characters like ^Z.## Since this program is comparatively slow, it is not suitable# for processing very large files.## There are several useful extensions that could be added to this program,# including other character representations, an option to skip an initial# portion of the input file, and suppression of long ranges of identical# characters.############################################################################### Requires: co-expressions############################################################################### Program note:## This program illustrates a situation in which co-expressions can be# used to considerably simplify programming. Try recasting it without# co-expressions.#############################################################################procedure main(arg) local width, chars, nonprint, prntc, asc, hex, sym, dec local oct, ascgen, hexgen, octgen, chrgen, prtgen, c local cnt, line, length, bar, input input := open(arg[1],"u") | stop("*** cannot open input file") width := 16 chars := string(&cset) nonprint := chars[1:33] || chars[128:0] prntc := map(chars,nonprint,repl(" ",*nonprint)) asc := table(" |") hex := table() sym := table() dec := table() oct := table() ascgen := create "NUL" | "SOH" | "STX" | "ETX" | "EOT" | "ENQ" | "ACK" | "BEL" | " BS" | " HT" | " LF" | " VT" | " FF" | " CR" | " SO" | " SI" | "DLE" | "DC1" | "DC2" | "DC3" | "DC4" | "NAK" | "SYN" | "ETB" | "CAN" | " EM" | "SUB" | "ESC" | " FS" | " GS" | " RS" | " US" | " SP" hexgen := create !"0123456789ABCDEF" || !"0123456789ABCDEF" octgen := create (0 to 3) || (0 to 7) || (0 to 7) chrgen := create !chars prtgen := create !prntc every c := !&cset do { asc[c] := @ascgen || "|" oct[c] := @octgen || "|" hex[c] := " " || @hexgen || "|" sym[c] := " " || @prtgen || " |" } asc[char(127)] := "DEL|" # special case cnt := -1 # to handle zero-indexing of byte count while line := reads(input,width) do { # read one line's worth length := *line # may not have gotten that many bar := "\n" || repl("-",5 + length * 4) write() writes("BYTE|") every writes(right(cnt + (1 to length),3),"|") write(bar) writes(" HEX|") every writes(hex[!line]) write(bar) writes(" OCT|") every writes(oct[!line]) write(bar) writes(" DEC|") every writes(right(ord(!line),3),"|") write(bar) writes(" SYM|") every writes(sym[!line]) write(bar) writes(" ASC|") every writes(asc[!line]) write(bar) cnt +:= length }end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldfilter.icn
############################################################################## Name: filter.icn## Title: Generic filter skeleton in Icon## Author: Robert J. Alexander## Date: December 5, 1989############################################################################### Generic filter skeleton in Icon.## This program is not intended to be used as is -- it serves as a# starting point for creation of filter programs. Command line# options, file names, and tabbing are handled by the skeleton. You# need only provide the filtering code.## As it stands, filter.icn simply copies the input file(s) to# standard output.## Multiple files can be specified as arguments, and will be processed# in sequence. A file name of "-" represents the standard input file.# If there are no arguments, standard input is processed.############################################################################### Links: options#############################################################################link optionsprocedure main(arg) local opt, tabs, Detab, fn, f, line # # Process command line options and file names. # opt := options(arg,"t+") # e.g. "fs:i+r." (flag, string, integer, real) if *arg = 0 then arg := ["-"] # if no arguments, standard input tabs := (\opt["t"] | 8) + 1 # tabs default to 8 Detab := tabs = 1 | detab # if -t 0, no detabbing # # Loop to process files. # every fn := !arg do { f := if fn == "-" then &input else open(fn) | stop("Can't open input file \"",fn,"\"") # # Loop to process lines of file (in string scanning mode). # while line := Detab(read(f)) do line ? { write(line) # copy line to standard output } # # Close this file. # close(f) } # # End of program. #end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldformat.icn
############################################################################## Name: format.icn## Title: Filter to word wrap a range of text## Author: Robert J. Alexander## Date: December 5, 1989############################################################################### Filter to word wrap a range of text.## A number of options are available, including full justification (see# usage text, below). All lines that have the same indentation as the# first line (or same comment leading character format if -c option)# are wrapped. Other lines are left as is.## This program is useful in conjunction with editors that can invoke# filters on a range of selected text.## The -c option attemps to establish the form of a comment based on the# first line, then does its best to deal properly with the following# lines. The types of comment lines that are handled are those in# which each line starts with a "comment" character string (possibly# preceded by spaces). While formatting comment lines, text lines# following the prototype line that don't match the prototype but are# flush with the left margin are also formatted as comments. This# feature simplifies initially entering lengthy comments or making# major modifications, since new text can be entered without concern# for comment formatting, which will be done automatically later.############################################################################### Links: options#############################################################################link optionsglobal widthprocedure main(arg) local usage, opts, tabs, comment, format, just1, space, nspace, wchar local line, pre, empty, outline, spaces, word, len # # Process the options. # usage := "usage: ifmt [-n] [-w N] [-t N]\n_ \t-w N\tspecify line width (default 72)\n_ \t-t N\tspecify tab width (default 8)\n_ \t-j\tfully justify lines\n_ \t-J\tfully justify last line\n_ \t-c\tattemp to format program comments\n_ \t-h\tprint help message" opts := options(arg,"ht+w+cjJ") if \opts["h"] then stop(usage) width := \opts["w"] | 72 tabs := \opts["t"] | 8 comment := opts["c"] format := if \opts["j"] then justify else 1 just1 := opts["J"] # # Initialize variables. # space := ' \t' nspace := ~space wchar := nspace # # Read the first line to establish a prototype of comment format # if -c option, or of leading spaces if normal formatting. # line := ((tabs >= 2,detab) | 1)(read(),tabs) | exit() line ? pre := (tab(many(space)) | "") || if \comment then tab(many(nspace)) || tab(many(space)) | stop("### Can't establish comment pattern") else "" width -:= *pre empty := trim(pre) outline := spaces := "" repeat { line ? { # # If this line indicates a formatting break... # if (=empty & pos(0)) | (=pre & any(space) | pos(0)) | (/comment & not match(pre)) then { write(pre,"" ~== outline) outline := spaces := "" write(line) } # # Otherwise continue formatting. # else { =pre tab(0) ? { tab(many(space)) while word := tab(many(wchar)) & (tab(many(space)) | "") do { if *outline + *spaces + *word > width then { write(pre,"" ~== format(outline)) outline := spaces := "" } outline ||:= spaces || word spaces := if any('.:?!',word[-1]) then " " else " " } } } } line := ((tabs >= 2,detab) | 1)(read(),tabs) | break } write(((tabs >= 2,entab) | 1)(pre,tabs), "" ~== (if \just1 then justify else 1)(outline))end## justify() -- add spaces between words until the line length = "width".#procedure justify(s) local min, spaces, len while *s < width do { min := 10000 s ? { while tab(find(" ")) do { len := *tab(many(' ')) if min >:= len then spaces := [] if len = min then put(spaces,&pos) } } if /spaces then break s[?spaces+:0] := " " } return send :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldgcomp.icn
############################################################################## Name: gcomp.icn## Title: Produce complement of file specification## Author: William H. Mitchell, modified by Ralph E. Griswold ## Date: December 27, 1989############################################################################### This program produces a list of the files in the current directory# that do not appear among the arguments. For example,# # gcomp *.c# # produces a list of files in the current directory that do# not end in .c. As another example, to remove all the files# in the current directory that do not match Makefile, *.c, and *.h# the following can be used:# # rm `gcomp Makefile *.c *.h`# # The files . and .. are not included in the output, but other# `dot files' are.#############################################################################e main(args) local files files := set() read(open("echo * .*","rp")) ? while insert(files,tab(upto(' ') | 0)) do move(1) | break every delete(files,"." | ".." | !args) every write(!sort(files))end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldgrpsort.icn
############################################################################## Name: grpsort.icn## Title: Sort groups of lines## Author: Thomas R. Hicks## Date: June 10, 1988############################################################################## # This program sorts input containing ``records'' defined to be# groups of consecutive lines. Output is written to standard out-# put. Each input record is separated by one or more repetitions# of a demarcation line (a line beginning with the separator# string). The first line of each record is used as the key.# # If no separator string is specified on the command line, the# default is the empty string. Because all input lines are trimmed# of whitespace (blanks and tabs), empty lines are default demarca-# tion lines. The separator string specified can be an initial sub-# string of the string used to demarcate lines, in which case the# resulting partition of the input file may be different from a# partition created using the entire demarcation string.# # The -o option sorts the input file but does not produce the# sorted records. Instead it lists the keys (in sorted order) and# line numbers defining the extent of the record associated with# each key.# # The use of grpsort is illustrated by the following examples.# The command# # grpsort "catscats" <x >y# # sorts the file x, whose records are separated by lines containing# the string "catscats", into the file y placing a single line of# "catscats" between each output record. Similarly, the command# # grpsort "cats" <x >y# # sorts the file x as before but assumes that any line beginning# with the string "cats" delimits a new record. This may or may not# divide the lines of the input file into a number of records dif-# ferent from the previous example. In any case, the output# records will be separated by a single line of "cats". Another# example is# # grpsort -o <bibliography >bibkeys# # which sorts the file bibliography and produces a sorted list of# the keys and the extents of the associated records in bibkeys.# Each output key line is of the form:# # [s-e] key# # where# # s is the line number of the key line# e is the line number of the last line# key is the actual key of the record# # ############################################################################## Links: usage#############################################################################link usageglobal lcount, linelst, ordflagprocedure main(args) local division, keytable, keylist, line, info, nexthdr, null linelst := [] keytable := table() lcount := 0 if *args = 2 then if args[1] == "-o" then ordflag := pop(args) else Usage("groupsort [-o] [separator string] <file >sortedfile") if *args = 1 then { if args[1] == "?" then Usage("groupsort [-o] [separator string] <file >sortedfile") if args[1] == "-o" then ordflag := pop(args) else division := args[1] } if *args = 0 then division := "" nexthdr := lmany(division) | fail # find at least one record or quit info := [nexthdr,[lcount]] # gather all data lines for this group/record while line := getline() do { if eorec(division,line) then { # at end of this record # enter record info into sort key table put(info[2],lcount-1) enter(info,keytable) # look for header of next record if nexthdr := lmany(division) then info := [nexthdr,[lcount]] # begin next group/record else info := null } } # enter last line info into sort key table if \info then { put(info[2],lcount) enter(info,keytable) } keylist := sort(keytable,1) # sort by record headers if \ordflag then printord(keylist) # list sorted order of records else printrecs(keylist,division) # print records in orderend# enter - enter the group info into the sort key tableprocedure enter(info,tbl) if /tbl[info[1]] then # new key value tbl[info[1]] := [info[2]] else put(tbl[info[1]],info[2]) # add occurrance infoend# eorec - suceed if a delimiter string has been found, fail otherwiseprocedure eorec(div,str) if div == "" then # If delimiter string is empty, if str == div then return # then make exact match else fail if match(div,str) then return # Otherwise match initial string. else failend# getline - get the next line (or fail), trim off trailing tabs and blanks.procedure getline() local line static trimset initial trimset := ' \t' if line := trim(read(),trimset) then { if /ordflag then # save only if going to print later put(linelst,line) lcount +:= 1 return line }end# lmany - skip over many lines matching string div.procedure lmany(div) local line while line := getline() do { if eorec(div,line) then next #skip over multiple dividing lines return line }end# printord - print only the selection order of the records.procedure printord(slist) local x, y every x := !slist do every y := !x[2] do write(y[1],"-",y[2],"\t",x[1])end# printrecs - write the records in sorted order, separated by div string.procedure printrecs(slist,div) local x, y, z every x := !slist do every y := !x[2] do { every z := y[1] to y[2] do write(linelst[z]) write(div) }end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldhufftab.icn
############################################################################## Name: hufftab.icn## Title: Comnpute state transitions for Huffman decoding.## Author: Gregg M. Townsend## Date: December 1, 1984############################################################################### Each input line should be a string of 0s & 1s followed by a value# field. Output is a list of items in a form suitable for inclusion# by a C program as initialization for an array. Each pair of items# indicates the action to be taken on receipt of a 0 or 1 bit from the# corresponding state; this is either a state number if more decoding# is needed or the value field from the input if not. State 0 is the# initial state; 0 is output only for undefined states. States are# numbered by two to facilitate use of a one-dimensional array.## sample input: corresponding output:# 00 a /* 0 */ 2, c, a, 4, 0, b,# 011 b# 1 c [new line started every 10 entries]## Interpretation:# from state 0, input=0 => go to state 2, input=1 => return c# from state 2, input=0 => return a, input=1 => go to state 4# from state 4, input=0 => undefined, input=1 => return b#############################################################################global curstate, sttab, lineprocedure main() local code, val, n sttab := list() put(sttab) put(sttab) while line := read() do { line ? { if ="#" | pos(0) then next (code := tab(many('01'))) | (write(&errout,"bad: ",line) & next) tab(many(' \t')) val := tab(0) } curstate := 1 every bit(!code[1:-1]) curstate +:= code[-1] if \sttab[curstate] then write(&errout,"dupl: ",line) sttab[curstate] := val } write("/* generated by machine -- do not edit! */") write() writes("/* 0 */") out(sttab[1]) every n := 2 to *sttab do { if n % 10 = 1 then writes("\n/* ",n-1," */") out(sttab[n]) } write() endprocedure bit (c) curstate +:= c if integer(sttab[curstate]) then { curstate := sttab[curstate] return } if type(sttab[curstate]) == "string" then write(&errout,"dupl: ",line) curstate := sttab[curstate] := *sttab + 1 put(sttab) put(sttab) endprocedure out(v) if type(v) == "integer" then writes(right(v-1,6),",") else writes(right(\v | "0",6),",") end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldilnkxref.icn
############################################################################## Name: ilnkxref.icn## Title: Icon "link" Cross Reference Utility## Author: Robert J. Alexander## Date: December 5, 1989############################################################################### Utility to create cross reference of library files used in Icon# programs (i.e., those files named in "link" declarations).## ilnkxref <icon source file>...############################################################################### Links: wrap#############################################################################link wrapprocedure main(arg) local p, spaces, sep, proctable, maxlib, maxfile, fn, f, i, root local comma, line, libname, x, head, fill # # Initialize # if *arg = 0 then { p := open("ls *.icn","rp") while put(arg,read(p)) close(p) } spaces := ' \t' sep := ' \t,' proctable := table() maxlib := maxfile := 0 # # Gather information from files. # every fn := !arg do { write(&errout,"File: ",fn) f := open(fn) | stop("Can't open ",fn) i := 0 every i := find("/",fn) root := fn[1:find(".",fn,i + 1) | 0] comma := &null while line := read(f) do { line ? { tab(many(spaces)) if \comma | ="link " then { write(&errout," ",line) comma := &null tab(many(spaces)) until pos(0) | match("#") do { libname := tab(upto(sep) | 0) put(\proctable[libname],root) | (proctable[libname] := [root]) maxlib <:= *libname maxfile <:= *root tab(many(spaces)) comma := &null if comma := ="," then tab(many(spaces)) } } } } close(f) } # # Print the cross reference table. # write() every x := !sort(proctable) do { head := left(x[1],maxlib + 3) fill := repl(" ",*head) every x := !sort(x[2]) do { write(head,wrap(left(x,maxfile + 2),78)) & head := fill } write(head,wrap()) }end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldipp.icn
############################################################################## Name: ipp.icn## Title: Icon preprocessor## Author: Robert C. Wieland## Date: December 22, 1989############################################################################### Ipp is a preprocessor for the Icon language. Ipp has many operations and# features that are unique to the Icon environment and should not be used as a# generic preprocessor (such as m4). Ipp produces output which when written to# a file is designed to be the source for icont, the command processor for Icon# programs.# # Ipp may be invoked from the command line as:## ipp [option ...] [ifile [ofile]]# # Two file names may be specified as arguments. 'ifile' and 'ofile' are # respectively the input and output files for the preprocessor. By default# these are standard input and standard output. If the output file is to be# specified while the input file should remain standard input a dash ('-')# should be given as 'ifile'. For example, 'ipp - test' makes test the output# file while retaining standard input as the input file.# # The following special names are predefined by ipp and may not be redefined# or undefined. The name _LINE_ is defined as the line number (as an# integer) of the line of the source file currently processed. The# name _FILE_ is defined as the name of the current source file (as a string). # If the source is standard input then it has the value 'stdin'.# # Also predefined are names corresponding to the features supported by the# implementation of Icon at the location the preprocessor is run. This allows# conditional translations using the 'if' commands, depending on what features# are available. Given below is a list of the features on a 4.nbsd UNIX # implementation and the corresponding predefined names:# # Feature Name# -----------------------------------------------------# UNIX UNIX# co-expressions co_expressions# overflow checking overflow_checking# direct execution direct_execution# environment variables environment_variables# error traceback error_traceback# executable images executable_images# string invocation string_invocation# expandable regions expandable_regions# # # Command-Line Options:# ---------------------# # The following options to ipp are recognized:# # -C By default ipp strips Icon-style comments. If this option# is specified all comments are passed along except those# found on ipp command lines (lines starting with a '$' # command).# # -D name # -D name=def Allows the user to define a name on the command line instead# of using a $define command in a source file. In the first# form the name is defined as '1'. In the second form name is# defined as the text following the equal sign. This is less# powerful than the $define command line since def can not# contain any white space (spaces or tabs).# # -d depth By default ipp allows include files to be nested to a depth# of ten. This allows the preprocessor to detect infinitely# recursive include sequences. If a different limit for the# nesting depth is needed it may changed by using this option# with an integer argument greater than zero. Also, if a file# is found to already be in a nested include sequence an# error message is written regardless of the limit.# # -I dir The following algorithm is normally used in searching for# $include files. Names enclosed in <> are always expected to # in the /usr/icon/src directory. On a UNIX system names enclosed# in "" are searched for by trying in order the directories# specified by the PATH environment variable. On other systems# only the current directory is searched. If the -I option is# given the directory specified is searched before the 'standard'# directories. If this option is specified more than once the# directories specified are tried in the order that they appear# on the command line, then followed by the 'standard' # directories.# # # Preprocessor commands:# ----------------------# # All ipp commands start with lines beginning with a '$'. The name of the# command must immediately follow the '$'. Any line beginning with a '$'# and not followed by a valid name will cause an error message to be sent# to standard error and termination of the preprocessor. If the command# requires an argument then it must be separated from the command name by# white space (any number of spaces or tabs) otherwise the argument will be# considered part of the name and the result will likely produce an error.# In processing the # commands ipp responds to exceptional conditions in one# of two ways. It may produce a warning and continue processing or produce an# error message and terminate. In both cases the message is sent to standard# error. With the exception of error conditions encountered during the# processing of the command line, the messages normally include the name and# line number of the source file at the point the condition was# encountered. Ipp was designed so that most exception conditions# encountered will produce errors and terminate. This protects the user since# warnings could simply be overlooked or misinterpreted.## Many ipp command require names as arguments. Names must begin with a# letter or an underscore, which may be followed by any number of letters,# underscores, and digits. Icon-style comments may appear on ipp command# lines, however they must be separated from the normal end of the command by# white_space. If any extraneous characters appear on a command line a# warning is issued. This occurs when characters other than white-space or a# comment follow the normal end of a command.# # The following commands are implemented:# # $define: This command may be used in one of two forms. The first form# only allows simple textual substitution. It would be invoked as# '$define name text'. Subsequent occurrencegs of name are replaced # with text. Name and text must be separated by one white space# character which is not considered to be part of the replacement# text. Normally the replacement text ends at the end of the line.# The text however may be continued on the next line if the backslash# character '\' is the last character on the line. If name occurs# in the replacement text an error message (recursive textual substi-# tution) is written.# # The second form is '$define name(arg,...,arg) text' which defines# a macro with arguments. There may be no white space between the # name and the '('. Each occurrenceg of arg in the replacement text# is replaced by the formal arg specified when the macro is # encountered. When a macro with arguments is expanded the arguments# are placed into the expanded replacement text unchanged. After the# entire replacement text is expanded, ipp restarts its scan for names# to expand at the beginning of the newly formed replacement text. # As with the first form above, the replacement text may be continued# an following lines. The replacement text starts immediately after# the ')'. # The names of arguments must comply with the convention for regular # names. See the section below on Macro processing for more # information on the replacement process.# # $undef: Invoked as '$undef name'. Removes the definition of name. If# name is not a valid name or if name is one of the reserved names# _FILE_ or _LINE_ a message is issued.# # $include: Invoked as '$include <filename>' or '$include "filename"'. This# causes the preprocessor to make filename the new source until# end of file is reached upon which input is again taken from the# original source. See the -I option above for more detail.# # $dump: This command, which has no arguments, causes the preprocessor to # write to standard error all names which are currently defined.# See '$ifdef' below for a definition of 'defined'.# # $endif: This command has no arguments and ends the section of lines begun# by a test command ($ifdef, $ifndef, or $if). Each test command# must have a matching $endif.# # $ifdef: Invoked as 'ifdef name'. The lines following this command appear# in the output only if the name given is defined. 'Defined' means# 1. The name is a predefined name and was not undefined using# $undef, or# 2. The name was defined using $define and has not been undefined# by an intervening $undef.# # $ifndef: Invoked as 'ifndef name'. The lines following this command do not# appear in the ouput if the name is not defined.# # $if: Invoked as 'if constant-expression'. Lines following this command# are processed only if the constant-expression produces a result.# The following arithmetic operators may be applied to integer # arguments: + - * / % ^## If an argument to one of the above operators is not an integer an# error is produced.# # The following functions are provided: def(name), ndef(name)# This allows the utility of $ifdef and $ifndef in a $if command.# def produces a result if name is defined and ndef produces a# result if name is not defined. There must not be any white space# between the name of the function and the '(' and also between the# name and the surrounding parentheses.# # The following comparision operators may be used on integer# operands:## > >= = < <= ~=## Also provided are alternation (|) and conjunction(&). The# following table lists all operators with regard to decreasing# precedence:# # ^ (associates right to left)# * / %# + -# > >= = < <= ~=# |# &# # The precedence of '|' and '&' are the same as the corresponding# Icon counterparts. Parentheses may be used for grouping.# # $else This command has no arguments and reverses the notion of the test# command which matches this directive. If the lines preceding this# command where ignored the lines following are processed, and vice# versa.# # Macro Processing and Textual Substitution# -----------------------------------------# No substitution is performed on text inside single quotes (cset literals)# and double quotes (strings) when a line is processed. The preprocessor will# detect unclosed cset literals or strings on a line and issue an error message# unless the underscore character is the last character on the line. The# output from # # $define foo bar# write("foo")# # is## write("foo")# # Unless the -C option is specified comments are stripped from the source.# Even if the option is given the text after the '#' is never expanded.# # Macro formal parameters are recognized in $define bodies even inside cset # constants and strings. The output from# # $define test(a) "a"# test(processed)# # is the following sequence of characters: "processed".# # Macros are not expanded while processing a $define or $undef. Thus:# # $define off invalid# $define bar off# $undef off# bar# # produces off. The name argument to $ifdef or $ifndef is also not expanded.# # Mismatches between the number of formal and actual parameters in a macro# call are caught by ipp. If the number of actual parameters is greater than# the number of formal parameters is error is produced. If the number of# actual parameters is less than the number of formal parameters a warning is# issued and the missing actual parameters are turned into null strings.# ############################################################################## The records and global variables used by ipp are described below:## Src_desc: Record which holds the 'file descriptor' and name# of the corresponding file. Used in a stack to keep# track of the source files when $includes are used.# Opt_rec Record returned by the get_args() routine which returns# the options and arguments on the command line. options# is a cset containing options that have no arguments.# pairs is a list of [option, argument] pairs. ifile and# ofile are set if the input or output files have been# specified.# Defs_rec Record stored in a table keyed by names. Holds the# names of formal arguments, if any, and the replacement# text for that name.# Chars Cset of all characters that may appear in the input.# Defs The table holding the definition data for each name.# Depth The maximum depth of the input source stack.# Ifile Descriptor for the input file.# Ifile_name Name of the input file.# Init_name_char Cset of valid initial characters for names.# Line_no The current line number.# Name_char Cset of valid characters for names.# Non_name_char The complement of the above cset.# Ofile The descriptor of the output file.# Options Cset of no-argument options specified on the command# line.# Path_list List of directories to search in for "" include files.# Src_stack The stack of input source records.# Std_include_paths List of directories to search in for <> include files.# White_space Cset for white-space characters.# TRUE Defined as 1.#############################################################################record Src_desc(fd, fname)record Opt_rec(options, pairs, ifile, ofile)record Defs_rec(arg_list, text)global Chars, Defs, Depth, Ifile, Ifile_name, Init_name_char, Line_no, Name_char, Non_name_char, Ofile, Options, Path_list, Src_stack, Std_include_paths, White_space, TRUE procedure main(arg_list) local cmd, line, source init(arg_list) repeat { while line := read(Ifile) do { Line_no +:= 1 line ? { if tab(any('$')) then if cmd := tab(many(Chars)) then process_cmd(cmd) else error("Missing command") else write(Ofile, process_text(line)) } } # Get new source close(Ifile) if source := pop(Src_stack) then { Ifile := source.fd Ifile_name := source.fname Line_no := 0 } else break }endprocedure process_cmd(cmd) case cmd of { "dump": dump() "define": define() "undef": undefine() "include": include() "if": if_cond() "ifdef": ifdef() "ifndef": ifndef() "else" | "endif": error("No previous 'if' expression") "endif": error("No previous 'if' expression") default: error("Undefined command") } returnendprocedureg_list) local s TRUE := 1 Defs := table() Init_name_char := &letters ++ '_' Name_char := Init_name_char ++ &digits Non_name_char := ~Name_char White_space := ' \t\b' Chars := &ascii -- White_space Line_no := 0 Depth := 10 Std_include_paths := ["/usr/icon/src"] # Predefine features every s:= &features do { s[upto(' -', s)] := "_" Defs[s] := Defs_rec([], "1") } # Set path list for $include files given in "" Path_list := [] if \Defs["UNIX"] then getenv("PATH") ? while put(Path_list, 1(tab(upto(':')), move(1))) else put(Path_list, "") process_options(arg_list)endprocedure process_options(arg_list) local args, arg_opts, pair, simple_opts, tmp_list, value simple_opts := 'C' arg_opts := 'dDI' Src_stack := [] args := get_args(arg_list, simple_opts, arg_opts) if \args.ifile then { (Ifile := open(
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Fold
+++++ Continued from previous card +++++
args.ifile)) | stop("Can not open input file ", args.ifile) Ifile_name := args.ifile } else { Ifile := &input Ifile_name := "stdin" } if \args.ofile then (Ofile := open(args.ofile, "w")) | stop("Can not open output file", args.ofile) else Ofile := &output Options := args.options tmp_list := [] every pair := !args.pairs do case pair[1] of { "D": def_opt(pair[2]) "d": if (value := integer(pair[2])) > 0 then Depth := value else stop("Invalid argument for depth") "I": push(tmp_list, pair[2]) } Path_list := tmp_list ||| Path_listendprocedure get_args(arg_list, simple_opts, arg_opts) local arg, ch, get_ofile, i, opts, queue opts := Opt_rec('', []) queue := [] every arg := arg_list[i := 1 to *arg_list] do if arg == "-" then # Next argument should be output file get_ofile := (i = *arg_list - 1) | stop("Invalid position of '-' argument") else if arg[1] == "-" then # Get options every ch := !arg[2: 0] do if any(simple_opts, ch) then opts.options ++:= ch else if any(arg_opts, ch) then put(queue, ch) else stop("Invalid option - ", ch) else if ch := pop(queue) then # Get argument for option push(opts.pairs, [ch, arg]) else if \get_ofile then { # Get output file opts.ofile := arg get_ofile := &null } else { # Get input file opts.ifile := arg get_ofile := (i < *arg_list) } if \get_ofile | *queue ~= 0 then stop("Invalid number of arguments") return optsend# if_cond is the procedure for $if. The procedure const_expr() which # evaluates the constant expression may be found in expr.icn## Procedure true_cond is invoked if the evaluation of a previous $if, $ifdef, or# $ifndef causes subsequent lines to be processed. Lines will be processed# upto a $endif or a $else. If $else is encountered, lines are skipped until# the $endif matching the $else is encountered.## Procedure false_cond is invoked if the evaluation of a previous $if, $ifdef, # or $ifndef causes subsequent lines to be skipped. Lines will be skipped # upto a $endif or a $else. If $else is encountered, lines are processed until# the $endif matching the $else is encountered.## If called with a 1, procedure skip_to skips over lines until a $endif is # encountered. If called with 2, it skips until either a $endif or $else is # encountered.procedure if_cond() local expr if expr := (tab(many(White_space)) & not pos(0) & tab(0)) then conditional(const_expr(expr)) else error("Constant expression argument to 'if' missing")endprocedure ifdef() local name if name := 2(tab(many(White_space)), tab(any(Init_name_char)) || (tab(many(Name_char)) | ""), any(White_space) | pos(0)) then { tab(many(White_space)) if not(pos(0) | any('#')) then warning("Extraneous characters after argument to 'ifdef'") conditional(Defs[name]) } else error("Argument to 'ifdef' is not a valid name")end procedure ifndef() local name if name := 2(tab(many(White_space)), tab(any(Init_name_char)) || (tab(many(Name_char)) | ""), any(White_space) | pos(0)) then { tab(many(White_space)) if not(pos(0) | any('#')) then warning("Extraneous characters after argument to 'ifndef'") if \Defs[name] then conditional(&null) else conditional(TRUE) } else error("Argument to 'ifndef' is not a valid name")end procedure conditional(flag) if \flag then true_cond() else false_cond()endprocedure true_cond() local line while line := read(Ifile) & (Line_no +:= 1) do line ? { if tab(any('$')) then if tab(match("if")) then eval_cond() else if check_cmd("else") then { # Skip only until a $endif skip_to(1) | error("'endif' not encountered before end of file") return } else if check_cmd("endif") then return else process_cmd(tab(many(Chars))) | error("Undefined command") else write(Ofile, process_text(line)) } error("'endif' not encountered before end of file")endprocedure false_cond() local cmd, line # Skip to $else or $endif (cmd := skip_to(2)) | error("'endif' not encountered before end of file") if cmd == "endif" then return while line := read(Ifile) & (Line_no +:= 1) do line ? { if tab(any('$')) then if check_cmd("endif") then return else if tab(match("if")) then eval_cond() else process_cmd(tab(many(Chars))) | error("Undefined command") else write(Ofile, process_text(line)) } error("'endif' not encountered before end of file")endprocedure eval_cond() if tab(match("def")) & (any(White_space) | pos(0)) then ifdef() else if tab(match("ndef")) & (any(White_space) | pos(0)) then ifndef() else if any(White_space) | pos(0) then return const_expr(tab(0)) else error("Undefined command")endprocedure check_cmd(cmd) local s if (s := tab(match(cmd))) & (tab(many(White_space)) | pos(0)) then { if not(match("if", cmd) | pos(0) | any('#')) then warning("Extraneous characters after command") return s } else failendprocedure skip_to(n) local cmd, ifs, elses, line, s ifs := elses := 0 while line := read(Ifile) & (Line_no +:= 1) do line ? { if tab(any('$')) then if cmd := (check_cmd("endif") | (n = 2 & check_cmd("else"))) then if ifs = elses = 0 then return cmd else if cmd == "endif" then { ifs -:= 1 elses := 0 } else if elses = 0 then if ifs > 0 then elses := 1 else error("'$else' encountered before 'if'") else error("Previous '$else' not terminated by 'endif'") else if check_cmd("endif") then { ifs -:= 1 elses := 0 } else if check_cmd("if" | "ifdef" | "ifndef") then ifs +:= 1 else # $else if elses = 0 then if ifs > 0 then elses := 1 else error("'$else' encountered before 'if'") else error("Previous '$else' not terminated by 'endif'") }endprocedure define() local args, name, text if name := 2(tab(many(White_space)), tab(any(Init_name_char)) || (tab(many(Name_char)) | ""), any(White_space | '(') | pos(0)) then { if name == ("_LINE_" | "_FILE_") then error(name, " is a reserved name and can not be redefined") if tab(any('(')) then { # A macro if not upto(')') then error("Missing ')' in macro definition") args := get_formals() text := get_text(TRUE) } else { args := [] text := get_text() } if \Defs[name] then warning(name, " redefined") Defs[name] := Defs_rec(args, text) } else error("Illegal or missing name in define")endprocedure get_text(flag) local get_cont, text, line if \flag then text := (tab(many(White_space)) | "") || tab(0) else text := (tab(any(White_space)) & tab(0)) | "" if text[-1] == "\\" then { get_cont := TRUE text[-1] := "" while line := read(Ifile) do { Line_no +:= 1 text ||:= line if text[-1] == "\\" then text[-1] := "" else { get_cont := &null break } } } if \get_cont then error("Continuation line not found before end of file") return textendprocedure get_formals() local arg, args, ch, edited args := [] while arg := 1(tab(upto(',)')), ch := move(1)) do { if edited := (arg ? 2(tab(many(White_space)) | TRUE, tab(any(Init_name_char)) || (tab(many(Name_char)) | ""), tab(many(White_space)) | pos(0))) then put(args, edited) else if arg == "" then return [""] else error("Invalid formal argument in macro definition") if ch == ")" then break } return argsendprocedure undefine() local name if name := (tab(many(White_space)) & tab(many(Chars))) then { tab(many(White_space)) if not(pos(0) | any('#')) then warning("Extraneous characters after argument to undef") if not(name ? (tab(any(Init_name_char)), (tab(many(Name_char)) | ""), pos(0))) then warning("Argument to undef is not a valid name") if name == ("_LINE_" | "_FILE_") then error(name, " is a reserved name that can not be undefined") \Defs[name] := &null } else error("Name missing in undefine")endprocedure process_text(line) local add, entry, new, position, s, token static in_string, in_cset new := "" while *line > 0 do { add := "" line ? { if \in_string then { if new ||:= (tab(upto('"')) || move(1)) then in_string := &null else { new ||:= tab(0) if line[-1] ~== "_" then { in_string := &null warning("Unclosed double quote") } } } if \in_cset then { if new ||:= (tab(upto('\'')) || move(1)) then in_cset := &null else { new ||:= tab(0) if line[-1] ~== "_" then { in_cset := &null warning("Unclosed single quote") } } } new ||:= tab(many(White_space)) if token := tab(many(Name_char) | any(Non_name_char)) then { if token == "\"" then { # Process string new ||:= "\"" if ng then in_string := &null else { in_string := TRUE if pos(0) then { warning("Unclosed double quote") in_string := &null } } add ||:= tab(0) } else if token == "'" then { # Process cset literal new ||:= "'" if \in_cset then in_cset := &null else { in_cset := TRUE if pos(0) then { warning("Unclosed single quote") in_cset := &null } } add ||:= tab(0) } else if token == "#" then { if any(Options, "C") then new ||:= token || tab(0) else (new ||:= (token ? tab(upto('#')))) & tab(0) } else if token == "_LINE_" then new ||:= string(Line_no) else if token == "_FILE_" then new ||:= Ifile_name else if /(entry := Defs[token]) then new ||:= token else if *entry.arg_list = 0 then if in_text(token, entry.text) then error("Recursive textual substitution") else add := entry.text else if *entry.arg_list = 1 & entry.arg_list[1] == "" then { if move(2) == "()" then add := entry.text else error(token, ": Invalid macro call") } else { # Macro with arguments s := tab(bal(White_space, '(', ')') | 0) if not any('(', s) then error(token, ": Incomplete macro call") add := process_macro(token, entry, s) } } position := &pos } line := add || line[position: 0] } return newendprocedure process_macro(name, entry, s) local arg, args, new_entry, news, token s ? { args := [] if tab(any('(')) then { repeat { arg := tab(many(White_space)) | "" if token := tab(many(Chars -- '(,)')) then { if /(new_entry := Defs[token]) then arg ||:= token else if *new_entry.arg_list = 0 then arg ||:= new_entry.text else { # Macro with arguments if news := tab(bal(' \t\b,)', '(', ')')) then arg ||:= process_macro(token, new_entry, news) else error(token, ": Error in arguments to macro call") } } # if else if not any(',)') then error(name, ": Incomplete macro call") arg ||:= tab(many(White_space)) put(args, arg) if any(')') then break move(1) } # repeat if *args > *entry.arg_list then error(name, ": Too many arguments in macro call") else if *args < *entry.arg_list then warning(name, ": Missing arguments in macro call") return macro_call(entry, args) } # if }endprocedure macro_call(entry, args) local i, map, result, token, x, y x := create !entry.arg_list y := create !args map := table() while map[@x] := @y | "" entry.text ? { result := tab(many(Non_name_char)) | "" while token := tab(many(Name_char)) do { result ||:= \map[token] | token result ||:= tab(many(Non_name_char)) } } return resultendprocedure in_text(name, text) text ? return (pos(1) & tab(match(name)) & (upto(Non_name_char) | pos(0))) | (tab(find(name)) & move(-1) & tab(any(Non_name_char)) & move(*name) & any(Non_name_char) | pos(0))end# In order to simplify the evaluation the three relational operators that# are longer than one character (<= ~= >=) are replaced by one character# 'aliases'.## One problem with eval_expr() is that the idea of failure as opposed to# returning some special value can not be used. For example if def(UNIX)# fails eval_expr() would try to convert it to an integer as its next step.# We would only want func() to fail if the argument is not a valid function,# not if the function is valid and the call fails. 'Failure' is therefore# represented by &null.procedure const_expr(expr) local new, temp new := "" every new ||:= (" " ~== !expr) while new[find(">=", new) +: 2] := "\200" while new[find("<=", new) +: 2] := "\201" while new[find("~=", new) +: 2] := "\202" return \eval_expr(new) | &nullendprocedure eval_expr(expr) while expr ?:= 2(="(", tab(bal(')')), pos(-1)) return lassoc(expr, '&') | lassoc(expr, '|') | lassoc(expr, '<=>\200\201\202' | '+-' | '*/%') | rassoc(expr, '^') | func(expr) | integer(process_text(expr)) | error(expr, " : Integer expected")endprocedure lassoc(expr, op) local j expr ? { every j := bal(op) return eval(tab(\j), move(1), tab(0)) }endprocedure rassoc(expr, op) return expr ? eval(tab(bal(op)), move(1), tab(0))endprocedure func(expr) local name, arg expr ? { (name := tab(upto('(')), arg := (move(1) & tab(upto(')')))) | fail } if \name == ("def" | "ndef") then return name(arg) else error("Invalid function name") endprocedure eval(arg1, op, arg2) arg1 := process_text(\eval_expr(arg1)) | &null arg2 := process_text(\eval_expr(arg2)) | &null if (op ~== "&") & (op ~== "|") then (integer(arg1) & integer(arg2)) | error(map(op), " : Arguments must be integers") return case op of { "+": arg1 + arg2 "-": arg1 - arg2 "*": arg1 * arg2 "/": arg1 / arg2 "%": arg1 % arg2 "^": arg1 ^ arg2 ">": arg1 > arg2 "=": arg1 = arg2 "<": arg1 < arg2 "\200": arg1 >= arg2 "\201": arg1 <= arg2 "\202": arg1 ~= arg2 "|": alt(arg1, arg2) "&": conjunction(arg1, arg2) }endprocedure def(name) if \Defs[name] then return "" else return &nullendprocedure ndef(name) if \Defs[name] then return &null else return "" endprocedure alt(x, y) if \x then return x else if \y then return y else return &nullendprocedure conjunction(x, y) if \x & \y then return y else return &nullendprocedure map(op) return case op of { "\200": ">=" "\201": "<=" "\202": "~=" default: op }endprocedure dump() tab(many(White_space)) if not(pos(0) | any('#')) then warning("Extraneous characters after dump command") every write(&errout, (!sort(Defs))[1])endprocedure include() local ch, fname static fname_chars initial fname_chars := Chars -- '<>"' if fname := 3(tab(many(White_space)), (tab(any('"')) & (ch := "\"")) | (tab(any('<')) & (ch := ">")), tab(many(fname_chars)), tab(any('>"')) == ch, tab(many(White_space)) | pos(0)) then { if not(pos(0) | any('#')) then warning("Extraneous characters after include file name") if ch == ">" then find_file(fname, Std_include_paths) else find_file(fname, Path_list) } else error("Missing or invalid include
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Fold
+++++ Continued from previous card +++++
file name")end procedure find_file(fname, path_list) local ifile, ifname, path every path := !path_list do { if path == ("" | ".") then ifname := fname else ifname := path || "/" || fname if ifile := open(ifname) then { if *Src_stack >= Depth then { close(ifile) error("Possibly infinitely recursive file inclusion") } if ifname == (Ifile_name | (!Src_stack).fname) then error("Infinitely recursive file inclusion") push(Src_stack, Src_desc(Ifile, Ifile_name)) Ifile := ifile Ifile_name := ifname Line_no := 0 return } } error("Can not open include file ", fname)endprocedure def_opt(s) local name, text, Name s ? { name := tab(upto('=')) | tab(0) text := (move(1) & tab(0)) | "1" } if name == ("_LINE_" | "_FILE_") then error(name, " is a reserved name and can not be redefined by the -D option") if name ~==:= (tab(any(Init_name_char)) & tab(many(Name_char)) & pos(0)) then error(name, " : Illegal name argument to -D option") if \Defs[Name] then warning(name, " : redefined by -D option") Defs[name] := Defs_rec([], text)endprocedure warning(s1, s2) s1 ||:= \s2 write(&errout, Ifile_name, ": ", Line_no, ": ", "Warning " || s1)endprocedure error(s1, s2) s1 ||:= \s2 stop(Ifile_name, ": ", Line_no, ": ", "Error " || s1)end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldiprint.icn
############################################################################## Name: iprint.icn## Title: Print Icon program## Author: Robert J. Alexander## Date: June 10, 1988############################################################################## # The defaults are set up for printing of Icon programs, but# through command line options it can be set up to print programs# in other languages, too (such as C). This program has several# features:# # If a program is written in a consistent style, this program# will attempt to keep whole procedures on the same page. The# default is to identify the end of a print group (i.e. a pro-# cedure) by looking for the string "end" at the beginning of a# line. Through the -g option, alternative strings can be used to# signal end of a group. Using "end" as the group delimiter# (inclusive), comments and declarations prior to the procedure are# grouped with the procedure. Specifying a null group delimiter# string (-g '') suppresses grouping.# # Page creases are skipped over, and form-feeds (^L) imbedded in# the file are handled properly. (Form-feeds are treated as spaces# by many C compilers, and signal page ejects in a listing). Page# headings (file name, date, time, page number) are normally# printed unless suppressed by the -h option.# # Options:# # -n number lines.# # -pN page length: number of lines per page (default: 60# lines).# # -tN tab stop spacing (default: 8).# # -h suppress page headings.# # -l add three lines at top of each page for laser printer.# # -gS end of group string (default: "end").# # -cS start of comment string (default: "#").# # -xS end of comment string (default: none).# # -i ignore FF at start of line.# # Any number of file names specified will be printed, each# starting on a new page.# # For example, to print C source files such as the Icon source# code, use the following options:# # iprint -g ' }' -c '/*' -x '*/' file ...# # Control lines:# # Control lines are special character strings that occur at the# beginnings of lines that signal special action. Control lines# begin with the start of comment string (see options). The control# lines currently recognized are:# # <comment string>eject -- page eject (line containing "eject"# does not print).# # <comment string>title -- define a title line to print at top# of each page. Title text is separated from the <comment# string>title control string by one space and is terminated by# <end of comment string> or end of line, whichever comes first.# # <comment string>subtitle -- define a sub-title line to print# at top of each page. Format is parallel to the "title" control# line, above.# # If a page eject is forced by maximum lines per page being# exceeded (rather than intentional eject via control line, ff, or# grouping), printing of blank lines at the top of the new page is# suppressed. Line numbers will still be printed correctly.# ############################################################################## Links: options#############################################################################global pagelines,tabsize,lines,page,datetime,title,subtitle,pagestatus,blanks, group,numbers,noheaders,hstuff,gpat,comment,comment_end,laser, ignore_ffprocedure main(arg) local files,x &dateline ? {tab(find(",")) ; move(2) ; datetime := tab(0)} files := [] pagelines := 60 tabsize := 8 gpat := "end" comment := "#" while x := get(arg) do { if match("-",x) then { # Arg is an option case x[2] of { "n": numbers := "yes" "p": { pagelines := ("" ~== x[3:0]) | get(arg) if not (pagelines := integer(pagelines)) then stop("Invalid -p parameter: ",pagelines) } "t": { tabsize := ("" ~== x[3:0]) | get(arg) if not (tabsize := integer(tabsize)) then stop("Invalid -t parameter: ",tabsize) } "h": noheaders := "yes" "l": laser := "yes" "g": { gpat := ("" ~== x[3:0]) | get(arg) } "c": { comment := ("" ~== x[3:0]) | get(arg) } "x": { comment_end := ("" ~== x[3:0]) | get(arg) } "i": ignore_ff := "yes" default: stop("Invalid option ",x) } } else put(files,x) } if *files = 0 then stop("usage: iprint -options file ...\n_ options:\n_ \t-n\tnumber the lines\n_ \t-p N\tspecify lines per page (default 60)\n_ \t-t N\tspecify tab width (default 8)\n_ \t-h\tsuppress page headers\n_ \t-l\tadd 3 blank lines at top of each page\n_ \t-g S\tpattern for last line in group\n_ \t-c S\t'start of comment' string\n_ \t-x S\t'end of comment' string\n_ \t-i\tignore FF") every x := !files do expand(x)endprocedure expand(fn) local f,line,cmd,linenbr,fname f := open(fn) | stop("Can't open ",fn) fn ? { while tab(find("/")) & move(1) fname := tab(0) } hstuff := fname || " " || datetime || " page " title := subtitle := &null lines := pagelines page := 0 ; linenbr := 0 group := [] while line := trim(read(f)) do { if \ignore_ff then while match("\f",line) do line[1] := "" linenbr +:= 1 if match("\f",line) then { dumpgroup() lines := pagelines repeat { line[1] := "" if not match("\f",line) then break } } line ? { if =comment & cmd := =("eject" | "title" | "subtitle") then { dumpgroup() case cmd of { # Command line "title": (move(1) & title := trim(tab(find(comment_end)))) | (title := &null) "subtitle": (move(1) & subtitle := trim(tab(find(comment_end)))) | (subtitle := &null) } lines := pagelines } else { # Ordinary (non-command) line if not (*group = 0 & *line = 0) then { put(group,line) if \numbers then put(group,linenbr) } if endgroup(line) then dumpgroup() } } } dumpgroup() close(f) lines := pagelinesendprocedure dumpgroup() local line,linenbr if *group > 0 then { if lines + *group / ((\numbers & 2) | 1) + 2 >= pagelines then lines := pagelines else {write("\n") ; lines +:= 2} while line := get(group) do { if \numbers then linenbr := get(group) if lines >= pagelines then { printhead() } if *line = 0 then { if pagestatus ~== "empty" then {blanks +:= 1 ; lines +:= 1} next } every 1 to blanks do write() blanks := 0 pagestatus := "not empty" if \numbers then writes(right(linenbr,5)," ") write(detab(line)) lines +:= 1 } } returnendprocedure endgroup(s) return match("" ~== gpat,s)endprocedure printhead() static ff,pg writes(ff) ; ff := "\f" lines := 0 pg := string(page +:= 1) if /noheaders then { if \laser then write("\n\n") write(left(\title | "",79 - *hstuff - *pg),hstuff,pg) lines +:= 2 write(\subtitle) & lines +:= 1 write() } pagestatus := "empty" blanks := 0 returnendprocedure detab(s) local t t := "" s ? { while t ||:= tab(find("\t")) do { t ||:= repl(" ",tabsize - *t % tabsize) move(1) } t ||:= tab(0) } return tend :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldipsort.icn
############################################################################## Name: ipsort.icn## Title: Sort Icon procedures## Author: Ralph E. Griswold## Date: June 10, 1988############################################################################## # This program reads an Icon program and writes an equivalent# program with the procedures sorted alphabetically. Global, link,# and record declarations come first in the order they appear in# the original program. The main procedure comes next followed by# the remaining procedures in alphabetical order.# # Comments and white space between declarations are attached to# the next following declaration.# # Limitations: This program only recognizes declarations that start# at the beginning of a line.# # Comments and interline white space between declarations may# not come out as intended.# ############################################################################procedure main() local line, x, i, proctable, proclist, comments, procname comments := [] # list of comment lines proctable := table() # table of procedure declarations while line := read() do { line ? { if ="procedure" & # procedure declaration tab(many('\t ')) & procname := tab(upto('(')) | stop("*** bad syntax: ",line) then { # if main, force sorting order if procname == "main" then procname := "\0main" proctable[procname] := x := [] while put(x,get(comments)) # save it put(x,line) while line := read() do { put(x,line) if line == "end" then break } } # other declarations else if =("global" | "record" | "link") then { while write(get(comments)) write(line) } else put(comments,line) } } while write(get(comments)) proclist := sort(proctable,3) # sort procedures while get(proclist) do every write(!get(proclist))end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldipsplit.icn
############################################################################## Name: ipsplit.icn## Title: Split Icon program into separate files## Author: Ralph E. Griswold## Date: June 10, 1988############################################################################## # This progam reads an Icon program and writes each procedure to# a separate file. The output file names consist of the procedure# name with .icn appended. If the -g option is specified, any glo-# bal, link, and record declarations are written to that file. Oth-# erwise they are written in the file for the procedure that# immediately follows them.# # Comments and white space between declarations are attached to# the next following declaration.# # Notes:## The program only recognizes declarations that start at the# beginning of lines. Comments and interline white space between# declarations may not come out as intended.# # If the -g option is not specified, any global, link, or record# declarations that follow the last procedure are discarded.# ############################################################################## Links: options#############################################################################link optionsprocedure main(args) local line, x, i, proctable, proclist, comments, gfile, gname, ofile local opts comments := [] opts := options(args,"g:") if gname := \opts["g"] then { gfile := open(gname,"w") | stop("*** cannot open ",gname) } proctable := table() while line := read() do { if line ? { ="procedure" & # procedure declaration tab(many(' ')) & proctable[tab(upto('('))] := x := [] } then { while put(x,get(comments)) # save it put(x,line) i := 1 while line := read() do { put(x,line) if line == "end" then break } } # other declarations else if \gfile & line ? =("global" | "record" | "link") then { while write(gfile,get(comments)) write(gfile,line) } else put(comments,line) } while write(\gfile,get(comments)) proclist := sort(proctable,3) # sort procedures while x := get(proclist) do { # output procedures ofile := open(x || ".icn","w") | stop("cannot write ",x,".icn") every write(ofile,!get(proclist)) close(ofile) }end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldipxref.icn
############################################################################## Name: ipxref.icn## Title: Produce cross reference for Icon program## Author: Allan J. Anderson## Date: June 10, 1988############################################################################## # This program cross-references Icon programs. It lists the# occurrences of each variable by line number. Variables are listed# by procedure or separately as globals. The options specify the# formatting of the output and whether or not to cross-reference# quoted strings and non-alphanumerics. Variables that are followed# by a left parenthesis are listed with an asterisk following the# name. If a file is not specified, then standard input is cross-# referenced.# # Options: The following options change the format defaults:# # -c n The column width per line number. The default is 4# columns wide.# # -l n The starting column (i.e. left margin) of the line# numbers. The default is column 40.# # -w n The column width of the whole output line. The default# is 80 columns wide.# # Normally only alphanumerics are cross-referenced. These# options expand what is considered:# # -q Include quoted strings.# # -x Include all non-alphanumerics.# # Note: This program assumes the subject file is a valid Icon pro-# gram. For example, quotes are expected to be matched.# ############################################################################## Bugs:## In some situations, the output is not properly formatted.############################################################################### Links: options#############################################################################link optionsglobal resword, linenum, letters, alphas, var, buffer, qflag, infile, xflagglobal inmaxcol, inlmarg, inchunk, localvar, linrecord procrec(pname,begline,lastline)procedure main(args) local word, w2, p, prec, i, L, ln, switches, nfile resword := ["break","by","case","default","do","dynamic","else","end", "every","fail","global","if","initial","link", "local","next","not", "of","procedure", "record","repeat","return","static","suspend","then", "to","until","while"] linenum := 0 var := table() # var[variable[proc]] is list of line numbers prec := [] # list of procedure records localvar := [] # list of local variables of current routine buffer := [] # a put-back buffer for getword proc := "global" letters := &letters ++ '_' alphas := letters ++ &digits switches := options(args,"qxw+l+c+") if \switches["q"] then qflag := 1 if \switches["x"] then xflag := 1 inmaxcol := \switches["w"] inlmarg := \switches["l"] inchunk := \switches["c"] infile := open(args[1],"r") # could use some checking while word := getword() do if word == "link" then { buffer := [] lin := "" next } else if word == "procedure" then { put(prec,procrec("",linenum,0)) proc := getword() | break p := pull(prec) p.pname := proc put(prec,p) } else if word == ("global" | "link" | "record") then { word := getword() | break addword(word,"global",linenum) while (w2 := getword()) == "," do { if word == !resword then break word := getword() | break addword(word,"global",linenum) } put(buffer,w2) } else if word == ("local" | "dynamic" | "static") then { word := getword() | break put(localvar,word) addword(word,proc,linenum) while (w2 := getword()) == "," do { if word == !resword then break word := getword() | break put(localvar,word) addword(word,proc,linenum) } put(buffer,w2) } else if word == "end" then { proc := "global" localvar := [] p := pull(prec) p.lastline := linenum put(prec,p) } else if word == !resword then next else { ln := linenum if (w2 := getword()) == "(" then word ||:= " *" # special mark for procedures else put(buffer,w2) # put back w2 addword(word,proc,ln) } every write(!format(var)) write("\n\nprocedures:\tlines:\n") L := [] every p := !prec do put(L,left(p.pname,16," ") || p.begline || "-" || p.lastline) every write(!sort(L))endprocedure addword(word,proc,lineno) if any(letters,word) | \xflag then { /var[word] := table() if /var[word]["global"] | (word == !\localvar) then { /(var[word])[proc] := [word,proc] put((var[word])[proc],lineno) } else { /var[word]["global"] := [word,"global"] put((var[word])["global"],lineno) } }endprocedure getword() local j, c static i, nonwhite initial nonwhite := ~' \t\n' repeat { if *buffer > 0 then return get(buffer) if /lin | i = *lin + 1 then if lin := read(infile) then { i := 1 linenum +:= 1 } else fail if i := upto(nonwhite,lin,i) then { # skip white space j := i if lin[i] == ("'" | "\"") then { # don't xref quoted words if /qflag then { c := lin[i] i +:= 1 repeat if i := upto(c ++ '\\',lin,i) + 1 then if lin[i - 1] == c then break else i +:= 1 else { i := 1 linenum +:= 1 lin := read(infile) | fail } } else i +:= 1 } else if lin[i] == "#" then { # don't xref comments; get next line i := *lin + 1 } else if i := many(alphas,lin,i) then return lin[j:i] else { i +:= 1 return lin[i - 1] } } else i := *lin + 1 } # repeatendprocedure format(T) local V, block, n, L, lin, maxcol, lmargin, chunk, col initial { maxcol := \inmaxcol | 80 lmargin := \inlmarg | 40 chunk := \inchunk | 4 } L := [] col := lmargin every V := !T do every block := !V do { lin := left(block[1],16," ") || left(block[2],lmargin - 16," ") every lin ||:= center(block[3 to *block],chunk," ") do { col +:= chunk if col >= maxcol - chunk then { lin ||:= "\n\t\t\t\t\t" col := lmargin } } if col = lmargin then lin := lin[1:-6] # came out exactly even put(L,lin) col := lmargin } L := sort(L) push(L,"variable\tprocedure\t\tline numbers\n") return Lend :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Folditab.icn
############################################################################## Name: itab.icn## Title: Entab an Icon program## Author: Robert J. Alexander## Date: December 5, 1989############################################################################### itab -- Entab an Icon program, leaving quoted strings alone.## itab [input-tab-spacing] [output-tab-spacing] # < source-program > entabbed-program## Observes Icon Programming Language conventions for escapes and# continuations in string constants. Input and output tab spacing# defaults to 8.#############################################################################global mapchars,intabsprocedure main(arg) local outtabs, line, c, nonwhite, delim intabs := (arg[1] | 8) + 1 outtabs := (arg[2] | 8) + 1 line := "" while c := readx() do { if not any(' \t',c) then nonwhite := 1 case c of { "\n": { write(map(entab(line,outtabs),\mapchars," \t") | line) line := "" nonwhite := &null } "'" | "\"": { (/delim := c) | (delim := &null) line ||:= c } "\\": line ||:= c || readx() default: { line ||:= if \delim & \nonwhite & \mapchars then map(c," \t",mapchars) else c } } }endprocedure readx() static buf,printchars initial { buf := "" printchars := &cset[33:128] } if *buf = 0 then { buf := detab(read(),intabs) || "\n" | fail mapchars := (printchars -- buf)[1+:2] | &null } return 1(.buf[1],buf[1] := "")end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldiundecl.icn
############################################################################## Name: undeclared.icn## Title: Utility to find undeclared variables in Icon source program.## Author: Robert J. Alexander## Date: March 11, 1990############################################################################### This program invokes icont to find undeclared variables in an Icon# source program. The output is in the form of a "local" declaration,# preceded by a comment line that identifies that procedure and file# name from whence it arose. Beware that undeclared variables aren't# necessarily local, so any which are intended to be global must be# removed from the generated list.## Multiple files can be specified as arguments, and will be processed# in seqA file name of "-" represents the standard input file.# If there are no arguments, standard input is processed.## The program works only if procedures are formatted such that the# keywords "procedure" and "end" are the first words on their# respective lines.## Only for UNIX, since the "p" (pipe) option of open() is used.############################################################################### Requires: UNIX#############################################################################link filenameprocedure main(arg) local f, fn, line, names, p, sep, t, argstring, undeclared, pn # # Process command line file names. # if *arg = 0 then arg := ["-"] # if no arguments, standard input # # Build a set of all the undeclared identifiers. # argstring := "" every argstring ||:= " " || !arg p := open("icont -s -u -o /dev/null 2>&1" || argstring,"p") | stop("popen failed") undeclared := set() while line := read(p) do line ? if find("undeclared identifier") then tab(find("\"") + 1) & insert(undeclared,tab(find("\""))) close(p) # # Loop through files to process individual procedures. # every fn := !arg do { f := if fn == "-" then &input else { fn := \suffix(fn)[1] || ".icn" open(fn) | stop("Can't open input file \"",fn,"\"") } # # Loop to process lines of file (in string scanning mode). # while line := read(f) do line ? { if tab(many(' \t')) | "" & ="procedure" & tab(many(' \t')) then { t := open("undeclared_tmp.icn","w") | stop("Can't open work file") write(t,line) while line := read(f) do line ? { write(t,line) if tab(many(' \t')) | "" & ="end" & many(' \t') | pos(0) then break } close(t) # # Now we have an isolated Icon procedure -- invoke icont to # determine its undeclared variables. # p := open("icont -s -u -o /dev/null 2>&1 undeclared_tmp.icn","p") | stop("popen failed") names := [] while line := read(p) do line ? if find("undeclared identifier") then tab(find("\"") + 1) & put(names,member(undeclared,tab(find("\"")))) close(p) # # Output the declaration. # pn := "\"" || tab(upto(' \t(')) || "\"" || if *arg > 1 then " (" || fn || ")" else "" if *names = 0 then write("# ",pn," is OK") else { write("# Local declarations for procedure ",pn) sep := "local " every writes(sep,!sort(names)) do sep := "," write() } } } # # Close this input file. # close(f) } remove("undeclared_tmp.icn")end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldiwriter.icn
############################################################################## Name: iwriter.icn## Title: Write Icon code to write input## Author: Ralph E. Griswold## Date: March 7, 1990############################################################################### Program that reads standard input and produces Icon expressions,# which when compiled and executed, write out the original input.## This is handy for incorporating, for example, message text in# Icon programs. Or even for writing Icon programs that write Icon# programs that ... .procedure main() while write("write(",image(read()),")")end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldkrieg.icn
############################################################################## Name: krieg.icn## Title: Play kriegspiel## Author: David J. Slate## Date: July 25, 1989############################################################################### The game:# # Kriegspiel (German for "war game") implements a monitor and, if desired,# an automatic opponent for a variation of the game of chess which has the# same rules and goal as ordinary chess except that neither player sees# the other's moves or pieces. Thus Kriegspiel combines the intricacies# and flavor of chess with additional elements of uncertainty, psychology,# subterfuge, etc., which characterize games of imperfect information such# as bridge or poker.# # The version of the game implemented here was learned by the author# informally many years ago. There may be other variations, and perhaps# the rules are actually written down somewhere in some book of games.# # The game is usually played in a room with three chess boards set up on# separate tables. The players sit at the two end tables facing away from# each other. A third participant, the "monitor", acts as a referee and# scorekeeper and keeps track of the actual game on the middle board,# which is also out of sight of either player. Since each player knows# only his own moves, he can only guess the position of the enemy pieces,# so he may place and move these pieces on his board wherever he likes.# # To start the game, the "White" player makes a move on his board. If the# move is legal, the monitor plays it on his board and invites "Black" to# make his response. If a move attempt is illegal (because it leaves the# king in check or tries to move through an enemy piece, etc.), the# monitor announces that fact to both players and the moving player must# try again until he finds a legal move. Thus the game continues until it# ends by checkmate, draw, or agreement by the players. Usually the# monitor keeps a record of the moves so that the players can play the# game over at its conclusion and see what actually happened, which is# often quite amusing.# # With no additional information provided by the monitor, the game is very# difficult but, surprisingly, still playable, with viable tactical and# strategic ideas. Usually, however, the monitor gives some minimal# feedback to both players about certain events. The locations of# captures are announced as well as the directions from which checks on# the kings originate.# # Even with the feedback about checks and captures, a newcomer to# Kriegspiel might still think that the players have so little information# that they could do little more than shuffle around randomly hoping to# accidentally capture enemy pieces or checkmate the enemy king. But in# fact a skilled player can infer a lot about his opponent's position and# put together plans with a good chance of success. Once he achieves a# substantial material and positional advantage, with proper technique he# can usually exploit it by mopping up the enemy pieces, promoting pawns,# and finally checkmating the enemy king as he would in an ordinary chess# game. In the author's experience, a skilled Kriegspiel player will win# most games against a novice, even if both players are equally matched at# regular chess.# # The implementation:# # The functions of this program are to replace the human monitor, whose# job is actually fairly difficult to do without mistakes, to permit the# players to play from widely separate locations, to produce a machine-# readable record of the game, and to provide, if desired, a computer# opponent for a single player to practice and spar with.# # When two humans play, each logs in to the same computer from a separate# terminal and executes his own copy of the program. This requires a# multi-tasking, multi-user operating system. For various reasons, the# author chose to implement Kriegspiel under Unix, using named pipes for# inter-process communication. The program has been tested successfully# under Icon Version 7.5 on a DecStation 3100 running Ultrix (a Berkeley-# style Unix) and also under Icon Version 7.0 on the ATT Unix-PC and# another System V machine, but unanticipated problems could be# encountered by the installer on other computers. An ambitious user may# be able to port the program to non-Unix systems such as Vax-VMS. It may# also be possible to implement Kriegspiel on a non-multi-tasking system# such as MS-DOS by using separate computers linked via serial port or# other network. See the "init" procedure for much of the system-# dependent code for getting user name, setting up communication files,# etc.# # Two prospective opponents should agree on who is to play "white", make# sure they know each other's names, and then execute Kriegspiel from# their respective terminals. The program will prompt each player for his# name (which defaults to his user or login name), his piece color, the# name of his opponent, whether he wishes to play in "totally blind" mode# (no capture or check information - not recommended for beginners), and# the name of the log file on which the program will leave a record of the# game (the program supplies a default in /tmp). Each program will set up# some communication files and wait for the opponent's to show up. Once# communication is established, each player will be prompted for moves and# given information as appropriate. The online "help" facility documents# various additional commands and responses.# # A player who wants a computer opponent should select "auto" as his# opponent's name. Play then proceeds as with a human opponent. "Auto"# is currently not very strong, but probably requires more than novice# skill to defeat.## Known bugs and limitations:## No bugs are currently known in the areas of legal move generation,# board position updating, checkmate detection, etc., but it is still# possible that there are a few.## Some cases of insufficient checkmating material on both sides are# not detected as draws by the program.## In the current implementation, a player may not play two# simultaneous games under the same user name with the same piece color.## If the program is terminated abnormally it may leave a communication# pipe file in /tmp.record board( pcs, cmv, cnm, caswq, caswk, casbq, casbk, fepp, ply)global Me, Yu, Mycname, Yrcname, Mycomm, Yrcomm, Logname, Logfile, Mycol, Yrcol, Blind, Bg, Frinclst, Lmv, Any, Tries, Remindprocedure automov( )# Returns a pseudo-randomly selected move type-in to be used in# "auto opponent" mode. But if possible, try to recapture (unless in# blind mode): local m, ms static anyflag initial anyflag := 0 if anyflag = 0 then { anyflag := 1 return "any" } anyflag := 0 ms := set( ) every insert( ms, movgen( Bg)) if / Any then { if find( ":", \ Lmv) & not find( "ep", \ Lmv) & / Blind then { every m := ! ms do { if m[ 4:6] == Lmv[ 4:6] & movlegal( Bg, m) then return m[ 2:6] || "Q" } } while * ms ~= 0 do { if movlegal( Bg, m := ? ms) then return m[ 2:6] || "Q" delete( ms, m) } return "end" } else { every m := ! ms do { if m[ 1] == "P" & m[ 6] == ":" & movlegal( Bg, m) then return m[ 2:6] || "Q" } return "end" }endprocedure chksqrs( b)# Generates the set of squares of pieces giving check in board b;# fails if moving side's king not in check: local sk sk := find( pc2p( "K", b.cmv), b.pcs) suspend sqratks( b.pcs, sk, b.cnm)endprocedure fr2s( file, rank)# Returns the square number corresponding to "file" and "rank"# numbers; fails if invalid file and/or rank: return (0 < (9 > file)) + 8 * (0 < ( 9 > rank)) - 8endprocedure gamend( b)# If the position b is at end of game,# return an ascii string giving the result; otherwise, fail: local nbn, sk sk := find( pc2p( "K", b.cmv), b.pcs) if not movlegal( b, movgen( b, sk)) & not movlegal( b, movgen( b)) then { if chksqrs( b) then { if b.cnm[ 1] == "W" then "1-0" else return "0-1" } else return "1/2-1/2" } else if not upto( 'PRQprq', b.pcs) then { nbn := 0 every upto( 'NBnb', b.pcs) do nbn +:= 1 if nbn < 2 then return "1/2-1/2" }end procedure init( )# init initializes the program: local whopipe, line, namdelim# Setup a data table for move generation: Frinclst := table( ) Frinclst[ "R"] := [ [1, 0], [0, 1], [-1, 0], [0, -1] ] Frinclst[ "N"] := [ [2, 1], [1, 2], [-1, 2], [-2, 1], [-2, -1], [-1, -2], [1, -2], [2, -1] ] Frinclst[ "B"] := [ [1, 1], [-1, 1], [-1, -1], [1, -1] ] Frinclst[ "Q"] := Frinclst[ "R"] ||| Frinclst[ "B"] Frinclst[ "K"] := Frinclst[ "Q"] Frinclst[ "r"] := Frinclst[ "R"] Frinclst[ "n"] := Frinclst[ "N"] Frinclst[ "b"] := Frinclst[ "B"] Frinclst[ "q"] := Frinclst[ "Q"] Frinclst[ "k"] := Frinclst[ "K"]# Setup a character set to delimit user names: namdelim := ~(&letters ++ &digits ++ '_.-')# Set reminder bell flag to off: Remind := ""# Set random number seed: &random := integer( map( "hxmysz", "hx:my:sz", &clock))# Get my name from user or "who am I" command and issue greeting: writes( "Your name (up to 8 letters & digits; default = user name)? ") line := read( ) | kstop( "can't read user name") Me := tokens( line, namdelim) if /Me then { whopipe := open( "who am i | awk '{print $1}' | sed 's/^.*!//'", "rp") Me := tokens( read( whopipe), namdelim) close( \whopipe) } if /Me then write( "Can't get user name from system.") while /Me do { writes( "Your name? ") line := read( ) | kstop( "can't get user name") Me := tokens( line, namdelim) } write( "Welcome, ", Me, ", to Kriegspiel (double blind chess).")# Prompt user to enter color: while writes( "Your color (w or b)? ") do { line := read( ) | kstop( "can't read color") if find( line[ 1], "WwBb") then break } Mycol := (find( line[ 1], "Ww"), "White") | "Black" Yrcol := map( Mycol, "WhiteBlack", "BlackWhite")# Prompt user to enter opponent name: writes( "Enter opponent's name (default = auto): ") Yu := tokens( read( ), namdelim) | "auto"# Prompt user to select "blind" mode, if desired: writes( "Totally blind mode (default is no)? ") Blind := find( (tokens( read( )) \ 1)[ 1], "Yy")# Set communication file names and create my communication file: if Yu == "auto" then { Mycname := "/dev/null" Yrcname := "/dev/null" } else { Mycname := "/tmp/krcom" || Mycol[ 1] || Me Yrcname := "/tmp/krcom" || Yrcol[ 1] || Yu remove( Mycname) system( "/etc/mknod " || Mycname || " p && chmod 644 " || Mycname) = 0 | kstop( "can't create my comm file") }# Get name of my log file, open it, then remove from directory: Logname := "/tmp/krlog" || Mycol[ 1] || Me while /Logfile do { writes( "Log file name (defaults to ", Logname, ")? ") line := read( ) | kstop( "can't read log file name") Logname := tokens( line) Logfile := open( Logname, "cr") } remove( Logname)# Open our communication files, trying to avoid deadlock: write( "Attempting to establish communication with ", Yu) if Mycol == "White" then Mycomm := open( Mycname, "w") | kstop( "can't open my comm file") while not (Yrcomm := open( Yrcname)) do { write( "Still attempting to establish communication") if system( "sleep 3") ~= 0 then kstop( "gave up on establishing communications") } if Mycol == "Black" then Mycomm := open( Mycname, "w") | kstop( "can't open my comm file")# Initialize board and moves: Bg := board( "RNBQKBNRPPPPPPPP pppppppprnbqkbnr", "White", "Black", "W-Q", "W-K", "B-Q", "B-K", &null, 0)# Initialize set of move tries: Tries := set( ) write( Logfile, "Kriegspiel game begins ", &dateline) write( Logfile, Me, " is ", Mycol, "; ", Yu, " is ", Yrcol) \ Blind & write( Logfile, Me, " is in 'totally blind' mode!") write( "You have the ", Mycol, " pieces against ", Yu) \ Blind & write( "You have chosen to play in 'totally blind' mode!") write( "At the \"Try\" prompt you may type help for assistance.") write( "Initialization complete; awaiting first white move.") returnendprocedure kstop( s)# Clean up and terminate execution with message s: local logtemp close( \Mycomm) remove( \Mycname) write( \Logfile, "Kriegspiel game ends ", &dateline) logboard( \ Logfile, \ Bg) if seek( \Logfile) then { logtemp := open( Logname, "w") | kstop( "can't open my log file") every write( logtemp, ! Logfile) write( "Game log is on file ", Logname) } stop( "Kriegspiel stop: ", s)endprocedure logboard( file, b)# Print the full board position in b to file: local f, r, p write( file, "Current board position:") write( file, " a b c d e f g h") every r := 8 to 1 by -1 do { write( file, "-------------------------") every writes( file, "|", p2c( p := b.pcs[ fr2s( 1 to 8, r)])[ 1], pc2p( p, "W")) write( file, "|", r) } write( file, "-------------------------") writes( file, b.cmv, " to move;") writes( file, " enp file: ", "abcdefgh"[ \ b.fepp], ";") writes( file, " castle mvs ", b.caswq || " " || b.caswk || " " || b.casbq || " " || b.casbk, ";") write( file, " half-mvs played ", b.ply) write( file, "")endprocedure main( ) local line# Initialize player names and colors and establish communications: init( )# Loop validating our moves and processing opponent responses: repeat { while Mycol == Bg.cmv do { writes( Remind, "Try your (", Me, "'s) move # ", Bg.ply / 2 + 1, ": ") line := read( ) | kstop( "player read fail") write( Mycomm, line) write( Logfile, Me, " typed: ", line) line := map( tokens( line)) | "" case line of { "" : 0 left( "any", *line) : myany( ) left( "board", *line) : myboard( ) "end" : myend( ) left( "help", *line) : myhelp( ) left( "message", *line) : mymessage( ) left( "remind", *line) : myremind( ) default : mytry( line) } } while Yrcol == Bg.cmv do { if Yu == "auto" then line := automov( ) else line := read( Yrcomm) | kstop( "opponent read fail") write( Logfile, Yu, " typed: ", line) line := map( tokens( line)) | "" case line of { "" : 0 left( "any", *line) : yrany( ) left( "board", *line) : 0 "end" : yrend( ) left( "help", *line) : 0 left( "message", *line) : yrmessage( ) left( "remind", *line) : 0 default : yrtry( line) } } }endprocedure movgen( b, s)# movgen generates the pseudo-legal moves in board position b from the# piece on square s; if s is unspecified all pieces are considered.# Note: pseudo-legal here means that the legality of the move has been# determined up to the question of whether it leaves the moving side's# king in check: local r, f, p, snfr, m, fto, rto, sl, sh, sto, fril, rp, r2, r4, r5, r7, ps ps := b.pcs sl := (\s | 1) sh := (\s | 64) every s := sl to sh do { if p2c( p := ps[ s]) == b.cmv then { f := s2f( s) r := s2r( s) snfr := s2sn( s)# Pawn moves: if find( p, "Pp") then { if p == "P" then { rp := 1; r2 := 2; r4 := 4; r5 := 5; r7 := 7 } else { rp := -1; r2 := 7; r4 := 5; r5 := 4; r7 := 2 } if ps[ sto := fr2s( f, r + rp)] == " " then { m := "P" || snfr || s2sn( sto) if r = r7 then s
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Fold
+++++ Continued from previous card +++++
uspend m || ! "RNBQ" else { suspend m if r = r2 & ps[ sto := fr2s( f, r4)] == " " then suspend "P" || snfr || s2sn( sto) } } every fto := 0 < (9 > (f - 1 to f + 1 by 2)) do { m := "P" || snfr || s2sn( sto := fr2s( fto, r + rp)) || ":" if p2c( ps[ sto]) == b.cnm then { if r = r7 then every suspend m || ! "RNBQ" else suspend m } if r = r5 & fto = \ b.fepp then suspend m || "ep" } }# Sweep piece (rook, bishop, queen) moves: else if find( p, "RBQrbq") then { every fril := ! Frinclst[ p] do { fto := f rto := r while sto := fr2s( fto +:= fril[ 1], rto +:= fril[ 2]) do { if ps[ sto] == " " then suspend pc2p( p, "W") || snfr || s2sn( sto) else { if p2c( ps[ sto]) == b.cnm then suspend pc2p( p, "W") || snfr || s2sn( sto) || ":" break } } } }# Knight and king moves: else if find( p, "KNkn") then { every fril := ! Frinclst[ p] do { if sto := fr2s( f + fril[ 1], r + fril[ 2]) then { if p2c( ps[ sto]) == b.cnm then suspend pc2p( p, "W") || snfr || s2sn( sto) || ":" else if ps[ sto] == " " then suspend pc2p( p, "W") || snfr || s2sn( sto) } } if p == "K" then { if (b.caswq ~== "", ps[ sn2s( "b1") : sn2s( "e1")] == " ", not sqratks( ps, sn2s( "d1"), "Black"), not sqratks( ps, sn2s( "e1"), "Black")) then suspend "Ke1c1cas" if (b.caswk ~== "", ps[ sn2s( "f1") : sn2s( "h1")] == " ", not sqratks( ps, sn2s( "f1"), "Black"), not sqratks( ps, sn2s( "e1"), "Black")) then suspend "Ke1g1cas" } else if p == "k" then { if (b.casbq ~== "", ps[ sn2s( "b8") : sn2s( "e8")] == " ", not sqratks( ps, sn2s( "d8"), "White"), not sqratks( ps, sn2s( "e8"), "White")) then suspend "Ke8c8cas" if (b.casbk ~== "", ps[ sn2s( "f8") : sn2s( "h8")] == " ", not sqratks( ps, sn2s( "f8"), "White"), not sqratks( ps, sn2s( "e8"), "White")) then suspend "Ke8g8cas" } } } }endprocedure movlegal( b, m)# Tests move m on board b and, if it does not leave the moving color in# check, returns m; fails otherwise: local ps, sfr, sto, sk ps := b.pcs sfr := sn2s( m[ 2:4]) sto := sn2s( m[ 4:6])# Castling move: if m[ 6:9] == "cas" then { if m == "Ke1c1cas" then return not sqratks( ps, sn2s( "c1"), "Black") & m if m == "Ke1g1cas" then return not sqratks( ps, sn2s( "g1"), "Black") & m if m == "Ke8c8cas" then return not sqratks( ps, sn2s( "c8"), "White") & m if m == "Ke8g8cas" then return not sqratks( ps, sn2s( "g8"), "White") & m }# Enpassant pawn capture: if m[ 6:9] == ":ep" then ps[ fr2s( s2f( sto), s2r( sfr))] := " "# All non-castling moves: ps[ sto] := ps[ sfr] ps[ sfr] := " " sk := find( pc2p( "K", b.cmv), ps) return not sqratks( ps, sk, b.cnm) & mendprocedure movmake( b, m)# Makes move m on board b: local sfr, sto if m == "Ke1c1cas" then { b.pcs[ sn2s( "a1")] := " " b.pcs[ sn2s( "d1")] := "R" } else if m == "Ke1g1cas" then { b.pcs[ sn2s( "h1")] := " " b.pcs[ sn2s( "f1")] := "R" } else if m == "Ke8c8cas" then { b.pcs[ sn2s( "a8")] := " " b.pcs[ sn2s( "d8")] := "r" } else if m == "Ke8g8cas" then { b.pcs[ sn2s( "h8")] := " " b.pcs[ sn2s( "f8")] := "r" } sfr := sn2s( m[ 2:4]) sto := sn2s( m[ 4:6]) b.pcs[ sto] := b.pcs[ sfr] b.pcs[ sfr] := " " if find( m[ -1], "rnbqRNBQ") then b.pcs[ sto] := pc2p( m[ -1], b.cmv) if sfr = sn2s( "e1") then b.caswq := b.caswk := "" if sfr = sn2s( "e8") then b.casbq := b.casbk := "" if (sfr | sto) = sn2s( "a1") then b.caswq := "" if (sfr | sto) = sn2s( "h1") then b.caswk := "" if (sfr | sto) = sn2s( "a8") then b.casbq := "" if (sfr | sto) = sn2s( "h8") then b.casbk := "" if m[ 6:9] == ":ep" then b.pcs[ fr2s( s2f( sto), s2r( sfr))] := " " b.fepp := &null if m[ 1] == "P" & abs( s2r( sfr) - s2r( sto)) = 2 then b.fepp := s2f( sto) b.ply +:= 1 b.cmv :=: b.cnmendprocedure movtry( m)# Tests whether the typed move m is legal in the global board Bg and, if so,# returns the corresponding move returned from movgen (which will be in a# different format with piece letter prefix, etc.). Fails if m is not# legal. Note that if the any flag is set, only captures by pawns are# allowed: local ml, mt, sfr, sto mt := map( tokens( m)) | "" if mt == "o-o" then mt := (Bg.cmv == "White", "e1g1") | "e8g8" else if mt == "o-o-o" then mt := (Bg.cmv == "White", "e1c1") | "e8c8" sfr := sn2s( mt[ 1:3]) | fail sto := sn2s( mt[ 3:5]) | fail if find( mt[ 5], "rnbq") then mt[ 5] := map( mt[ 5], "rnbq", "RNBQ") else mt := mt[ 1:5] || "Q" if \ Any then { if Bg.pcs[ sfr] ~== pc2p( "P", Bg.cmv) then fail every ml := movgen( Bg, sfr) do { if ml[ 4:7] == mt[ 3:5] || ":" then { if find( ml[ -1], "RNBQ") then ml[ -1] := mt[ 5] return movlegal( Bg, ml) } } } else { every ml := movgen( Bg, sfr) do { if ml[ 4:6] == mt[ 3:5] then { if find( ml[ -1], "RNBQ") then ml[ -1] := mt[ 5] return movlegal( Bg, ml) } } }endprocedure myany( )# Process my any command.# Check for captures by pawns and inform the player of any, and, if# at least one, set Any flag to require that player try only captures# by pawns: local m, p, s if \ Any then { write( "You have already asked 'Any' and received yes answer!") fail } p := pc2p( "P", Bg.cmv) if movlegal( Bg, 1( m := movgen( Bg, 1(s := 9 to 56, Bg.pcs[ s] == p)), m[ 6] == ":")) then { write( "Yes; you must now make a legal capture by a pawn.") Any := "Yes" } else write( "No.")endprocedure myboard( )# Process my board command by printing the board but omitting the# opponent's pieces and the enpassant status; a count of pieces of# both colors is printed:# Note: no board printed in blind mode. local f, r, p, nw, nb \ Blind & write( "Sorry; no board printout in blind mode!") & fail write( "Current board position (your pieces only):") write( " a b c d e f g h") every r := 8 to 1 by -1 do { write( "-------------------------") every f := 1 to 8 do { if (p2c( p := Bg.pcs[ fr2s( f, r)])) == Mycol then writes( "|", Mycol[ 1], pc2p( p, "W")) else writes( "| ") } write( "|", r) } write( "-------------------------") writes( Bg.cmv, " to move; ") writes( "castle mvs ", (Mycol == "White", Bg.caswq || " " || Bg.caswk) | Bg.casbq || " " || Bg.casbk) write( "; half-mvs played ", Bg.ply) nw := nb := 0 every upto( &ucase, Bg.pcs) do nw +:= 1 every upto( &lcase, Bg.pcs) do nb +:= 1 write( nw, " White pieces, ", nb, " Black.") write( "")endprocedure myend( )# Process my end command: kstop( "by " || Me)endprocedure myhelp( )# Process my help command: write( "") write( "This is \"Kriegspiel\" (war play), a game of chess between two") write( "opponents who do not see the location of each other's pieces.") write( "Note: the moves of the special opponent 'auto' are played by the") write( "program itself. Currently, auto plays at a low novice level.") write( "When it is your turn to move, you will be prompted to type") write( "a move attempt or one of several commands. To try a move,") write( "type the from and to squares in algebraic notation, as in: e2e4") write( "or b8c6. Castling may be typed as o-o, o-o-o, or as the move") write( "of the king, as in: e8g8. Pawn promotions should look like") write( "d7d8Q. If omitted, the piece promoted to is assumed to be a") write( "queen. Letters may be in upper or lower case. If the move is") write( "legal, it stands, and the opponent's response is awaited.") write( "If the move is illegal, the program will prompt you to") write( "try again. If the move is illegal because of the opponent's") write( "position but not impossible based on the position of your") write( "pieces, then your opponent will be informed that you tried") write( "an illegal move (note: this distinction between illegal and") write( "impossible is somewhat tricky and the program may, in some") write( "cases, not get it right). The program will announce the") write( "result and terminate execution when the game is over. You may") write( "then inspect the game log file which the program generated.") write( "") writes( "Type empty line for more or 'q' to return from help: ") if map( read( ))[ 1] == "q" then fail write( "") write( "The program will let you know of certain events that take place") write( "during the game. For each capture move, both players will be") write( "informed of the location of the captured piece. The opponent") write( "will be informed of a pawn promotion but not of the piece") write( "promoted to or the square on which the promotion takes place.") write( "When a player gives check, both players will be informed of the") write( "event and of some information about the direction from which the") write( "check arises, as in: check on the rank', 'check on the file',") write( "'check on the + diagonal', 'check on the - diagonal', or 'check") write( "by a knight'. For a double check, both directions are given.") write( "(A + diagonal is one on which file letters and rank numbers") write( "increase together, like a1-h8, and a - diagonal is one in which") write( "file letters increase while rank numbers decrease, as in a8-h1).") write( "") write( "Note: if you have selected the 'blind' mode, then you will") write( "receive no information about checks, captures, or opponent") write( "'any' or illegal move tries; nor will you be able to print") write( "the board. You will not even be told when your own pieces") write( "are captured. Except for answers to 'any' commands, the") write( "program will inform you only of when you have moved, when") write( "your opponent has moved, and of the result at end of game.") write( "") writes( "Type empty line for more or 'q' to return from help: ") if map( read( ))[ 1] == "q" then fail write( "") write( "Description of commands; note: upper and lower case letters") write( "are not distinguished, and every command except 'end' may be") write( "abbreviated.") write( "") write( "any") write( "") write( "The 'any' command is provided to speed up the process of trying") write( "captures by pawns. Since pawns are the only pieces that capture") write( "in a different manner from the way they ordinarily move, it is") write( "often useful to try every possible capture, since such a move") write( "can only be legal if it in fact captures something. Since the") write( "process of trying the captures can be time-consuming, the 'any'") write( "command is provided to signal your intent to try captures by") write( "pawns until you find a legal one. The program will tell you if") write( "you have at least one. If you do then you must try captures by") write( "pawns (in any order) until you find a legal one. Note that the") write( "opponent will be informed of your plausible 'any' commands (that") write( "is, those that are not impossible because you have no pawns on") write( "the board).") write( "") writes( "Type empty line for more or 'q' to return from help: ") if map( read( ))[ 1] == "q" then fail write( "") write( "board") write( "") write( "The 'board' command prints the current position of your") write( "pieces only, but also prints a count of pieces of both sides.") write( "Note: 'board' is disallowed in blind mode.") write( "") write( "end") write( "") write( "Then 'end' command informs the program and your") write( "opponent of your decision to terminate the game") write( "immediately.") write( "") write( "help") write( "") write( "The 'help' command prints this information.") write( "") writes( "Type empty line for more or 'q' to return from help: ") if map( read( ))[ 1] == "q" then fail write( "") write( "message") write( "") write( "The 'message' command allows you to send a one-line") write( "message to your opponent. Your opponent will be prompted") write( "for a one-line response. 'message' may be useful for such") write( "things as witty remarks, draw offers, etc.") write( "") write( "remind") write( "") write( "The 'remind' command turns on (if off) or off (if on) the") write( "bell that is rung when the program is ready to accept your") write( "move or command. The bell is initially off.") write( "")endprocedure mymessage( )# Process my message command: local line write( "Please type a one-line message:") line := read( ) | kstop( "can't read message") write( Mycomm, line) write( Logfile, line) write( "Awaiting ", Yu, "'s response") if Yu == "auto" then line := "I'm just your auto opponent." else line := read( Yrcomm) | kstop( "can't read message response") write( Yu, " answers: ", line) write( Logfile, line)endprocedure myremind( )# Process my remind command: if Remind == "" then Remind := "\^g" else Remind := ""endprocedure mytry( mt)# Process my move try mt: local ml, result if ml := movtry( mt) then { Lmv := ml write( Me, " (", Mycol, ") has moved.") write( Logfile, Me, "'s move ", Bg.ply / 2 + 1, " is ", ml) / Blind & write( Me, " captures on ", s2sn( sqrcap( Bg, ml))) movmake( Bg, ml) / Blind & saycheck( ) Any := &null Tries := set( ) if result := gamend( Bg) then { write( "Game ends; result: ", result) write( Logfile, "Result: ", result) kstop( "end of game") } } else write( "Illegal move, ", Me, "; try again:")endprocedure p2c( p)# Returns "White" if p is white piece code ("PRNBQK"), "Black"# if p is black piece code ("prnbqk"), and " " if empty square# (" "): if find( p, "PRNBQK") then return "White" else if find( p, "prnbqk") then return "Black" else return " "endprocedure pc2p( p, c)# Returns the piece letter for the piece of type p but color c;# returns " " if p == " ". Thus pc2p( "R", "Black") == "r".# c may be abbreviated to "W" or "B": if c[ 1] == "W" then return map( p, "prnbqk", "PRNBQK") else return map( p, "PRNBQK", "prnbqk")endprocedure s2f( square)# Returns the file number of the square number "square"; fails# if invalid square number: return ( (0 < ( 65 > integer( square))) - 1) % 8 + 1endprocedure s2r( square)# Returns the rank number of the square number "square"; fails# if invalid square number: return ( (0 < ( 65 > integer( square))) - 1) / 8 + 1endprocedure s2sn( square)# Returns the algebraic square name corresponding to square number# "square"; fails if invalid square number: return "abcdefgh"[ s2f( square)] || string( s2r( square))endprocedure saycheck( )# Announce checks, if any, in global board Bg: local s, sk sk := find( pc2p( "K", Bg.cmv), Bg.pcs) every s := chksqrs( Bg) do { writes( (Mycol == Bg.cnm, Me) | Yu, " checks ") if s2r( s) == s2r( sk) then write( "on the rank.") else if s2f( s) == s2f( sk) then write( "on the file.") else if ( s2f( s) - s2f( sk)) = ( s2r( s) - s2r( sk)) then write( "on the + diagonal.") else if ( s2f( s) - s2f( sk)) = ( s2r( sk) - s2r( s)) then write( "on the - diagonal.") else write( "by
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Fold
+++++ Continued from previous card +++++
knight.") }endprocedure sn2s( sn)# Returns the square number corresponding to the algebraic square# name sn; examples: sn2s( "a1") = 1, sn2s( "b1") = 2, sn2s( "h8") = 64.# Fails if invalid square name: return find( sn[ 1], "abcdefgh") + 8 * (0 < (9 > integer( sn[ 2]))) - 8endprocedure sqratks( ps, s, c)# Generates the numbers of squares of pieces of color c that "attack"# square s in board piece array ps; fails if no such squares: local file, rank, rfr, sfr, fril, p, ffr file := s2f( s) rank := s2r( s)# Check for attacks from pawns: rfr := (c == "White", rank - 1) | rank + 1 every sfr := fr2s( file - 1 to file + 1 by 2, rfr) do { if ps[ sfr] == pc2p( "P", c) then suspend sfr }# Check for attack from king or knights: every fril := ! Frinclst[ p := ("K" | "N")] do { if sfr := fr2s( file + fril[ 1], rank + fril[ 2]) then { if ps[ sfr] == pc2p( p, c) then suspend sfr } }# Check for attacks from sweep (rook and bishop) directions: every fril := ! Frinclst[ p := ("R" | "B")] do { ffr := file rfr := rank while sfr := fr2s( ffr +:= fril[ 1], rfr +:= fril[ 2]) do { if ps[ sfr] ~== " " then { if ps[ sfr] == pc2p( p | "Q", c) then suspend sfr break } } }endprocedure sqrcap( b, m)# Returns square of piece captured by move m in board b; fails if m# not a capture: local fto, rfr if m[ 6:9] == ":ep" then { fto := find( m[ 4], "abcdefgh") rfr := integer( m[ 3]) return fr2s( fto, rfr) } else if m[ 6] == ":" then return sn2s( m[ 4:6])endprocedure tokens( s, d)# Generate tokens from left to right in string s given delimiters in cset# d, where a token is a contiguous string of 1 or more characters not in# d bounded by characters in d or the left or right end of s.# d defaults to ' \t'. s := string( s) | fail d := (cset( d) | ' \t') s ? while tab( upto( ~d)) do suspend( tab( many( ~d)) \ 1)endprocedure yrany( )# Process opponent's any command: local m, p, s if \ Any then fail p := pc2p( "P", Bg.cmv) if not find( p, Bg.pcs) then fail / Blind & writes( Yu, " asked 'any' and was told ") if movlegal( Bg, 1( m := movgen( Bg, 1(s := 9 to 56, Bg.pcs[ s] == p)), m[ 6] == ":")) then { / Blind & write( "yes.") Any := "Yes" } else / Blind & write( "no.")endprocedure yrend( )# Process opponent's end command: write( "Game terminated by ", Yu, ".") kstop( "by " || Yu)endprocedure yrmessage( )# Process opponent's message command: local line line := read( Yrcomm) | kstop( "can't read opponent message") write( "Message from ", Yu, ": ", line) write( Logfile, line) write( "Please write a one-line response:") line := read( ) | kstop( "can't read response to opponent message") write( Mycomm, line) write( Logfile, line)endprocedure yrtry( mt)# Process opponent move try (or other type-in!) mt: local ml, result, s, mtr, b, po, sfr, sto if ml := movtry( mt) then { Lmv := ml write( Yu, " (", Yrcol, ") has moved.") write( Logfile, Yu, "'s move ", Bg.ply / 2 + 1, " is ", ml) / Blind & write( Yu, " captures on ", s2sn( sqrcap( Bg, ml))) if find( ml[ -1], "RNBQ") then / Blind & write( Yu, " promotes a pawn.") movmake( Bg, ml) / Blind & saycheck( ) Any := &null Tries := set( ) if result := gamend( Bg) then { write( "Game ends; result: ", result) write( Logfile, "Result: ", result) kstop( "end of game") } }# Inform Me if opponent move illegal but not impossible. Don't inform# if illegal move already tried. Note: distinction between "illegal"# and "impossible" is tricky and may not always be made properly.# Note: don't bother informing if in blind mode. else { \ Blind & fail mtr := map( tokens( mt)) | "" if mtr == "o-o" then mtr := (Bg.cmv == "White", "e1g1") | "e8g8" else if mtr == "o-o-o" then mtr := (Bg.cmv == "White", "e1c1") | "e8c8" mtr := mtr[ 1:5] | fail if member( Tries, mtr) then fail insert( Tries, mtr) b := copy( Bg) po := (b.cmv[ 1] == "W", "prnbqk") | "PRNBQK" b.pcs := map( b.pcs, po, " ") sfr := sn2s( mtr[ 1:3]) | fail sto := sn2s( mtr[ 3:5]) | fail if sn2s( movgen( b, sfr)[ 4:6]) = sto then / Any & write( Yu, " tried illegal move.") else { b.pcs[ sto] := pc2p( "P", b.cnm) if sn2s( movgen( b, sfr)[ 4:6]) = sto then write( Yu, " tried illegal move.") } }end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldkross.icn
############################################################################## Name: kross.icn## Title: Diagram character intersections of strings## Author: Ralph E. Griswold## Date: May 9, 1989############################################################################### This program procedure accepts pairs of strings on successive lines.# It diagrams all the intersections of the two strings in a common# character.#############################################################################procedure main() local line, j while line := read() do { kross(line,read()) }endprocedure kross(s1,s2) local j, k every j := upto(s2,s1) do every k := upto(s1[j],s2) do xprint(s1,s2,j,k)endprocedure xprint(s1,s2,j,k) write() every write(right(s2[1 to k-1],j)) write(s1) every write(right(s2[k+1 to *s2],j))end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldkwic.icn
###################################################################### Name: kwic.icn## Title: Produce keywords in context## Author: Stephen B. Wampler, modified by Ralph E. Griswold## Date: October 11, 1988############################################################################### This is a simple keyword-in-context (KWIC) program. It reads from# standard input and writes to standard output. The "key" words are# aligned in column 40, with the text shifted as necessary. Text shifted# left is truncated at the left. Tabs and other characters whose "print width"# is less than one may not be handled properly.## Some noise words are omitted (see "exceptions" in the program text).# If a file named except.wrd is open and readable i nthe current directory,# the words in it are used instead.## This program is pretty simple. Possible extensions include ways# of specifying words to be omitted, more flexible output formatting, and# so on. Another "embellisher's delight".#############################################################################global line, loc, exceptionsprocedure main() local exceptfile if exceptfile := open("except.wrd") then { exceptions := set() every insert(exceptions, lcword(exceptfile)) close(exceptfile) } else exceptions := set(["or", "in", "the", "to", "of", "on", "a", "an", "at", "and", "i", "it"]) every write(kwic(&input))endprocedure kwic(file) local index, word# Each word, in lowercase form, is a key in the table "index".# The corresponding values are lists of the positioned lines# for that word. This method may use an impractically large# amount of space for large input files. index := table() every word := lcword(file) do { if not member(exceptions,word) then { /index[word] := [] index[word] := put(index[word],position()) } }# Before the new sort options, it was done this way -- the code preserved# as an example of "generators in action".# suspend !((!sort(index,1))[2]) index := sort(index,3) while get(index) do suspend !get(index)endprocedure lcword(file) static chars initial chars := &ucase ++ &lcase ++ '\'' every line := !file do line ? while tab(loc := upto(chars)) do suspend map(tab(many(chars)) \ 1)endprocedure position() local offset# Note that "line" and ""loc" are global. offset := 40 - loc if offset >= 0 then return repl(" ",offset) || line else return line[-offset + 1:0]end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldlabels.icn
############################################################################## Name: labels.icn## Title: Format mailing labels## Author: Ralph E. Griswold## Date: June 10, 1988############################################################################## # This program produces labels using coded information taken# from the input file. In the input file, a line beginning with ## is a label header. Subsequent lines up to the next header or# end-of-file are accumulated and output so as to be centered hor-# izontally and vertically on label forms. Lines beginning with *# are treated as comments and are ignored.# # Options: The following options are available:# # -c n Print n copies of each label.# # -s s Select only those labels whose headers contain a char-# acter in s.# # -t Format for curved tape labels (the default is to format# for rectangular mailing labels).# # -w n Limit line width to n characters. The default width is# 40.# # -l n Limit the number of printed lines per label to n. The# default is 8.# # -d n Limit the depth of the label to n. The default is 9 for# rectangular labels and 12 for tape labels (-t).# # -f Print the first line of each selected entry instead of# labels.# # Options are processed from left to right. If the number of# printed lines is set to a value that exceeds the depth of the# label, the depth is set to the number of lines. If the depth is# set to a value that is less than the number of printed lines, the# number of printed lines is set to the depth. Note that the order# in which these options are specified may affect the results.# # Printing Labels: Label forms should be used with a pin-feed pla-# ten. For mailing labels, the carriage should be adjusted so that# the first character is printed at the leftmost position on the# label and so that the first line of the output is printed on the# topmost line of the label. For curved tape labels, some experi-# mentation may be required to get the text positioned properly.# # Diagnostics: If the limits on line width or the number of lines# per label are exceeded, a label with an error message is written# to standard error output.# ############################################################################## Links: options## See also: zipsort#############################################################################link optionsglobal line, lsize, repet, llength, ldepth, first, optsprocedure main(args) local selectors, y, i line := "" selectors := '#' lsize := 9 ldepth := 8 llength := 40 repet := 1 i := 0 opts := options(args,"cfd+l+s:tw+") if \opts["f"] then first := 1 selectors := cset(\opts["s"]) if \opts["t"] then { lsize := 12 if ldepth > lsize then ldepth := lsize } llength := nonneg("w") if ldepth := nonneg("l") then { if lsize < ldepth then lsize := ldepth } if lsize := nonneg("d") then { if ldepth > lsize then ldepth := lsize } repet := nonneg("c") repeat { # processing loop if line[1] == "#" & upto(selectors,line) then obtain() else { line := read() | break } }end# Obtain next label#procedure obtain() local label, max label := [] max := 0 line := "" while line := read() do { if line[1] == "*" then next if line[1] == "#" then break if \first then { write(line) return } else put(label,line) max <:= *line if *label > ldepth then { error(label[1],1) return } if max > llength then { error(label[1],2) return } } every 1 to repet do format(label,max)end# Format a label#procedure format(label,width) local j, indent indent := repl(" ",(llength - width) / 2) j := lsize - *label every 1 to j / 2 do write() every write(indent,!label) every 1 to (j + 1) / 2 do write()end# Issue label for an error#procedure error(name,type) static badform initial badform := list(lsize) case type of { 1: badform[3] := " **** too many lines" 2: badform[3] := " **** line too long" } badform[1] := name every write(&errout,!badform)endprocedure nonneg(s) s := \opts[s] | fail return 0 < integer(s) | stop("-",s," needs postive numeric parameter")end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldlam.icn
############################################################################## Name: lam.icn## Title: Laminate files## Author: Thomas R. Hicks## Date: June 10, 1988############################################################################## # This program laminates files named on the command line onto# the standard output, producing a concatenation of corresponding# lines from each file named. If the files are different lengths,# empty lines are substituted for missing lines in the shorter# files. A command line argument of the form - s causes the string# s to be inserted between the concatenated file lines.# # Each command line argument is placed in the output line at the# point that it appears in the argument list. For example, lines# from file1 and file2 can be laminated with a colon between each# line from file1 and the corresponding line from file2 by the com-# mand# # lam file1 -: file2# # File names and strings may appear in any order in the argument# list. If - is given for a file name, standard input is read at# that point. If a file is named more than once, each of its lines# will be duplicated on the output line, except that if standard# input is named more than once, its lines will be read alter-# nately. For example, each pair of lines from standard input can# be joined onto one line with a space between them by the command# # lam - "- " -# # while the command# # lam file1 "- " file1# # replicates each line from file1.# ############################################################################## Links: usage#####################################################################link usageglobal fndxsprocedure main(a) local bufs, i bufs := list(*a) fndxs := [] if (*a = 0) | a[1] == "?" then Usage("lam file [file | -string]...") every i := 1 to *a do { if a[i] == "-" then { a[i] := &input put(fndxs,i) } else if match("-",a[i]) then { bufs[i] := a[i][2:0] a[i] := &null } else { if not (a[i] := open(a[i])) then stop("Can't open ",a[i]) else put(fndxs,i) } } if 0 ~= *fndxs then lamr(a,bufs) else Usage("lam file [file | -string]...")endprocedure lamr(args,bufs) local i, j every i := !fndxs do bufs[i] := (read(args[i]) | &null) while \bufs[!fndxs] do { every j := 1 to *bufs do writes(\bufs[j]) write() every i := !fndxs do bufs[i] := (read(args[i]) | &null) }end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldlatexidx.icn
############################################################################## Name: latexidx.icn## Title: Process LaTeX .idx file## Author: David S. Cargo## Date: April 19, 1989############################################################################### Input:## A latex .idx file containing the \indexentry lines.## Output:## \item lines sorted in order by entry value,# with page references put into sorted order.## Processing:## While lines are available from standard input# Read a line containing an \indexentry# Form a sort key for the indexentry# If there is no table entry for it# Then create a subtable for it and assign it an initial value# If there is a table entry for it,# But not an subtable entry for the actual indexentry# Then create an initial page number set for it# Otherwise add the page number to the corresponding page number set# Sort the table of subtables by sort key value# For all subtables in the sorted list# Sort the subtables by indexentry values# For all the indexentries in the resulting list# Sort the set of page references# Write an \item entry for each indexentry and the page references## Limitations:## Length of index handled depends on implementation limits of memory alloc.# Page numbers must be integers (no roman numerals). Sort key formed by# mapping to lower case and removing leading articles (a separate function# is used to produce the sort key, simplifying customization) -- otherwise# sorting is done in ASCII order.#############################################################################procedure main() # no parameters, reading from stdin local key_table, s, page_num, itemval, key, item_list, one_item local page_list, refs key_table := table() # for items and tables of page sets while s := read() do # read strings from standard input { # start with s = "\indexentry{item}{page}" # save what's between the opening brace and the closing brace, # and reverse it s := reverse(s[upto('{',s)+1:-1]) # giving s = "egap{}meti" # reversing allows extracting the page number first, thereby allowing # ANYTHING to be in the item field # grab the "egap", reverse it, convert to integer, convert to set # in case of conversion failure, use 0 as the default page number page_num := set([integer(reverse(s[1:upto('{',s)])) | 0]) # the reversed item starts after the first closing brace # grab the "meti", reverse it itemval := reverse(s[upto('}', s)+1:0]) # allow the sort key to be different from the item # reform may be customized to produce different equivalence classes key := reform(itemval) # if the assigned value for the key is null if /key_table[key] then { # create a subtable for the key and give it its initial value key_table[key] := table() key_table[key][itemval] := page_num } # else if the assigned value for the itemval is null # (e. g., when the second itemval associated with a key is found) else if /key_table[key][itemval] # give it its initial value then key_table[key][itemval] := page_num # otherwise just add it to the existing page number set else key_table[key][itemval] ++:= page_num } # now that all the input has been read.... # sort keys and subtables by key value key_table := sort(key_table, 3) # loop, discarding the sort keys while get(key_table) do { # dequeue and sort one subtable into a list # sort is strictly by ASCII order within the equivalence class item_list := sort(get(key_table), 3) # loop, consuming the item and the page number sets as we go while one_item := get(item_list) do { # convert the page number set into a sorted list page_list := sort(get(item_list)) # dequeue first integer and convert to string refs := string(get(page_list)) # dequeue rest of page nums and append while (refs ||:= ", " || string(get(page_list))) write("\\item ", one_item, " ", refs) } } returnend# reform - modify the item to enforce sort order appropriately# This could do much more. For example it could strip leading braces,# control sequences, quotation marks, etc. It doesn't. Maybe later.procedure reform(item) item := map(item) # map to lowercase# drop leading article if present if match("a ", item) then return item[3:0] if match("an ", item) then return item[4:0] if match("the ", item) then return item[5:0] return itemend :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldlinden.icn
############################################################################## Name: linden.icn## Title: Generate sentences in Lindenmayer system## Author: Ralph E. Griswold## Date: October 11, 1988############################################################################### This program reads in a 0L-system (Lindenmayer system) consisting of# rewriting rules in which a string is rewritten with every character# replaced simultaneously (conpectually) by a specified string of# symbols.## The last line of input consists of an initial string followed by a colon# (which cannot be a symbol in the initial string) and the number of times# the rewriting rules are to be applied. An example is## 1->2#3# 2->2# 3->2#4# 4->504# 5->6# 6->7# 7->8(1)# 8->8# (->(# )->)# #->## 0->0# 1:14## Here, the initial string is "1" and the rewriting rules are to be# applied 14 times.## If no rule is provided for a character, the character is not changed# by rewriting. Thus, the example above can be expressed more concisely# as## 1->2#3# 3->2#4# 4->504# 5->6# 6->7# 7->8(1)# 1:14## If -a is given on the command line, each rewriting is written out.# Otherwise, only the final result is written out.## Reference:## Formal Languages, Arto Salomaa, Academic Press, 1973. pp. 234-252.############################################################################### Links: options#############################################################################link optionsglobal rewriteprocedure main(args) local line, count, axiom, detail, opts, i, result, s rewrite := table() # What follows is a trick. It takes advantage of the fact that Icon# functions are first-class data objects and that function invocation# and mutual evaluation have the same syntax. If -a is specified,# the value of "detail" becomes the function for writing and the# value of "write" becomes 1. See below. detail := 1 opts := options(args,"a") if \opts["a"] then detail :=: write while line := read() do if line[2:4] == "->" then rewrite[line[1]] := line[4:0] else { i := upto(':',line) # asssume last line result := line[1:i] count := line[i+1:0] break } detail(result) every result := detail(linden(result)) \ count write(result) # write the last result if not already writtenendprocedure linden(pstring) local c, s repeat { s := "" every c := !pstring do s ||:= (\rewrite[c] | c) suspend pstring := s }end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldlisp.icn
############################################################################## Name: lisp.icn## Title: Lips interpreter## Author: Stephen B. Wampler## Date: August 7, 1989####################################################################### This program is a simple interpreter for pure Lisp.## The syntax and semantics are based on EV-LISP, as described in# Laurent Siklossy's "Let's Talk LISP" (Prentice-Hall, 1976, ISBN# 0-13-532762-8). Functions that have been predefined match those# described in Chapters 1-4 of the book.## No attempt at improving efficiency has been made, this is# rather an example of how a simple LISP interpreter might be# implemented in Icon.## The language implemented is case-insensitive.## It only reads enough input lines at one time to produce at least# one LISP-expression, but continues to read input until a valid# LISP-expression is found.# # Errors:## fails on EOF; fails with error message if current# input cannot be made into a valid LISP-expression (i.e. more# right than left parens).# ############################################################################global words, # table of variable atoms T, NIL # universal constantsglobal trace_set # set of currently traced functionsrecord prop(v,f) # abbreviated propery list### main interpretive loop#procedure main()local sexpr initialize() every sexpr := bstol(getbs()) do PRINT([EVAL([sexpr])])end## (EVAL e) - the actual LISP interpreter#procedure EVAL(l)local fn, arglist, arg l := l[1] if T === ATOM([l]) then { # it's an atom if T === l then return .T if EQ([NIL,l]) === T then return .NIL return .((\words[l]).v | NIL) } if glist(l) then { # it's a list if T === ATOM([l[1]]) then case Map(l[1]) of { "QUOTE" : return .(l[2] | NIL) "COND" : return COND(l[2:0]) "SETQ" : return SET([l[2]]|||evlis(l[3:0])) "ITRACEON" : return (&trace := -1,T) "ITRACEOFF" : return (&trace := 0,NIL) default : return apply([l[1]]|||evlis(l[2:0])) | NIL } return apply([EVAL([l[1]])]|||evlis(l[2:0])) | NIL } return .NILend## apply(fn,args) - evaluate the functionprocedure apply(l)local fn, arglist, arg, value, fcn fn := l[1] if member(trace_set, Map(string(fn))) then { write("Arguments of ",fn) PRINT(l[2:0]) } if value := case Map(string(fn)) of { "CAR" : CAR([l[2]]) | NIL "CDR" : CDR([l[2]]) | NIL "CONS" : CONS(l[2:0]) | NIL "ATOM" : ATOM([l[2]]) | NIL "NULL" : NULL([l[2]]) | NIL "EQ" : EQ([l[2],l[3]]) | NIL "PRINT" : PRINT([l[2]]) | NIL "EVAL" : EVAL([l[2]]) | NIL "DEFINE" : DEFINE(l[2]) | NIL "TRACE" : TRACE(l[2]) | NIL "UNTRACE" : UNTRACE(l[2]) | NIL } then { if member(trace_set, Map(string(fn))) then { write("value of ",fn) PRINT(value) } return value } fcn := (\words[Map(fn)]).f | return NIL if type(fcn) == "list" then if Map(fcn[1]) == "LAMBDA" then { value := lambda(l[2:0],fcn[2],fcn[3]) if member(trace_set, Map(string(fn))) then { write("value of ",fn) PRINT(value) } return value } else return EVAL([fn]) return NILend## evlis(l) - evaluate everything in a list#procedure evlis(l)local arglist, arg arglist := [] every arg := !l do put(arglist,EVAL([arg])) | fail return arglistend### Initializations## initialize() - set up global values#procedure initialize() words := table() trace_set := set() T := "T" NIL := []end### Primitive Functions## (CAR l)#procedure CAR(l) return glist(l[1])[1] | NILend## (CDR l)#procedure CDR(l) return glist(l[1])[2:0] | NILend## (CONS l)#procedure CONS(l) return ([l[1]]|||glist(l[2])) | NILend## (SET a l)#procedure SET(l) (T === ATOM([l[1]])& l[2]) | return NIL /words[l[1]] := prop() if type(l[2]) == "prop" then return .(words[l[1]].v := l[2].v) else return .(words[l[1]].v := l[2])end## (ATOM a)#procedure ATOM(l) if type(l[1]) == "list" then return (*l[1] = 0 & T) | NIL return Tend## (NULL l)#procedure NULL(l) return EQ([NIL,l[1]])end## (EQ a1 a2)#procedure EQ(l) if type(l[1]) == type(l[2]) == "list" then return (0 = *l[1] = *l[2] & T) | NIL return (l[1] === l[2] & T) | NILend## (PRINT l)#procedure PRINT(l) if type(l[1]) == "prop" then return PRINT([l[1].v]) return write(strip(ltos(l)))end## COND(l) - support routine to eval# (for COND)procedure COND(l)local pair every pair := !l do { if type(pair) ~== "list" | *pair ~= 2 then { write(&errout,"COND: ill-formed pair list") return NIL } if T === EVAL([pair[1]]) then return EVAL([pair[2]]) } return NILend## (TRACE l)#procedure TRACE(l) local fn every fn := !l do { insert(trace_set, Map(fn)) } return NILend## (UNTRACE l)#procedure UNTRACE(l) local fn every fn := !l do { delete(trace_set, Map(fn)) } return NILend## glist(l) - verify that l is a list#procedure glist(l) if type(l) == "list" then return lend## (DEFINE fname definition)## This has been considerable rewritten (and made more difficult to use!)# in order to match EV-LISP syntax.procedure DEFINE(l) local fn_def, fn_list fn_list := [] every fn_def := !l do { put(fn_list, define_fn(fn_def)) } return fn_listend## Define a single function (called by 'DEFINE')#procedure define_fn(fn_def) /words[Map(fn_def[1])] := prop(NIL) words[Map(fn_def[1])].f := fn_def[2] return Map(fn_def[1])end## lambda(actuals,formals,def)#procedure lambda(actuals, formals, def)local save, act, form, pair, result, arg, i save := table() every arg := !formals do save[arg] := \words[arg] | prop(NIL) i := 0 every words[!formals] := (prop(actuals[i+:=1]|NIL)\1) result := EVAL([def]) every pair := !sort(save) do words[pair[1]] := pair[2] return resultend# Date: June 10, 1988#procedure getbs()static tmp initial tmp := ("" ~== |read()) || " " repeat { while not checkbal(tmp) do { if more(')','(',tmp) then break tmp ||:= (("" ~== |read()) || " ") | break } suspend balstr(tmp) tmp := (("" ~== |read()) || " ") | fail }end## checkbal(s) - quick check to see if s is# balanced w.r.t. parentheses#procedure checkbal(s) return (s ? 1(tab(bal()),pos(-1)))end## more(c1,c2,s) - succeeds if any prefix of# s has more characters in c1 than# characters in c2, fails otherwise#procedure more(c1,c2,s)local cnt cnt := 0 s ? while (cnt <= 0) & not pos(0) do { (any(c1) & cnt +:= 1) | (any(c2) & cnt -:= 1) move(1) } return cnt >= 0end## balstr(s) - generate the balanced disjoint substrings# in s, with blanks or tabs separating words## errors:# fails when next substring cannot be balanced##procedure balstr(s)static blanks initial blanks := ' \t' (s||" ") ? repeat { tab(many(blanks)) if pos(0) then break suspend (tab(bal(blanks))\1 | {write(&errout,"ill-formed expression") fail} ) \ 1 }end## bstol(s) - convert a balanced string into equivalent# list representation.#procedure bstol(s)static blankslocal l initial blanks := ' \t' (s||" ") ? {tab(many(blanks)) l := if not ="(" then s else [] } if not string(l) then every put(l,bstol(balstr(strip(s)))) return lend## ltos(l) - convert a list back into a string##procedure ltos(l) local tmp if type(l) ~== "list" then return l if *l = 0 then return "NIL" tmp := "(" every tmp ||:= ltos(!l) || " " tmp[-1] := ")" return tmpendprocedure strip(s) s ?:= 2(="(", tab(bal()), =")", pos(0)) return sendprocedure Map(s) return map(s, &lcase, &ucase)end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldloadmap.icn
############################################################################## Name: loadmap.icn## Title: Produce load map of UNIX obect file## Author: Stephen B. Wampler## Date: December 13, 1985############################################################################## # This program produces a formatted listing of selected symbol classes# from a compiled file. The listing is by class, and gives the# name, starting address, and length of the region associated with# each symbol.# # The options are:# # -a Display the absolute symbols.# # -b Display the BSS segment symbols.# # -c Display the common segment symbols.# #splay the data segment symbols.# # -t Display the text segment symbols.# # -u Display the undefined symbols.# # If no options are specified, -t is assumed.# # If the address of a symbol cannot be determined, ???? is given in# its place.# ############################################################################# # Notes:## The size of the last region in a symbol class is suspect and is# usually given as rem.# # Output is not particularly exciting on a stripped file.# ############################################################################## Requires: UNIX#############################################################################record entry(name,address)procedure main(args) local maptype, arg, file, nm, ldmap, tname, line, text, data, bss local SPACE, COLON, DIGITS, HEXDIGITS, usize, address, name, nmtype initial { if *args = 0 then stop("usage: loadmap [-t -d -b -u -a -c -l] file") SPACE := '\t ' COLON := ':' DIGITS := '0123456789' HEXDIGITS := DIGITS ++ 'abcdef' ldmap := table(6) ldmap["u"] := [] ldmap["d"] := [] ldmap["a"] := [] ldmap["b"] := [] ldmap["t"] := [] ldmap["c"] := [] tname := table(6) tname["u"] := "Undefined symbols" tname["a"] := "Absolute locations" tname["t"] := "Text segment symbols" tname["d"] := "Data segment symbols" tname["b"] := "BSS segment symbols" tname["c"] := "Common symbols" nmtype := "nm -gno " } maptype := "" every arg := !args do if arg[1] ~== "-" then file := arg else if arg == "-l" then nmtype := "nm -no " else if arg[1] == "-" then maptype ||:= (!"ltdbuac" == arg[2:0]) | stop("usage: loadmap [-t -d -b -u -a -c -l] file") maptype := if *maptype = 0 then "t" else string(cset(maptype)) write("\n",file,"\n") usize := open("size " || file,"rp") | stop("loadmap: cannot execute size") !usize ? { writes("Text space: ",right(text := tab(many(DIGITS)),6)," ") move(1) writes("Initialized Data: ",right(data := tab(many(DIGITS)),6)," ") move(1) write("Uninitialized Data: ",right(bss := tab(many(DIGITS)),6)) } close(usize) nm := open(nmtype || file,"rp") | stop("loadmap: cannot execute nm") every line := !nm do line ? { tab(upto(COLON)) & move(1) address := integer("16r" || tab(many(HEXDIGITS))) | "????" tab(many(SPACE)) type := map(move(1)) tab(many(SPACE)) name := tab(0) if find(type,maptype) then put(ldmap[type],entry(name,address)) } every type := !maptype do { if *ldmap[type] > 0 then { write("\n\n\n") write(tname[type],":") write() show(ldmap[type],(type == "t" & text) | (type == "d" & data) | (type == "b" & bss) | &null, ldmap[type][1].address) } }endprocedure show(l,ssize,base) local i1, i2, nrows static ncols initial ncols := 3 write(repl(repl(" ",3) || left("name",9) || right("addr",7) || right("size",6),ncols)) write() nrows := (*l + (ncols - 1)) / ncols every i1 := 1 to nrows do { every i2 := i1 to *l by nrows do writes(repl(" ",3),left(l[i2].name,9),right(l[i2].address,7), right(area(l[i2 + 1].address,l[i2].address) | if /ssize then "rem" else base + ssize - l[i2].address,6)) write() } returnendprocedure area(high,low) if integer(low) & integer(high) then return high - low else return "????"end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldmemsum.icn
############################################################################## Name: memsum.icn## Title: Summarize Icon memory management## Author: Ralph E. Griswold## Date: March 8, 1990############################################################################### This program is a filter for Icon allocation history files (see IPD113).# It tabulates the number of allocations by type and the total amount of# storage (in bytes) by type.## It takes an Icon allocation history file from standard input and writes to# standard output.## The command-line options are:## -t produce tab-separated output for use in spreadsheets (the# default is a formatted report# -d produce debugging output## Some assumptions are made about where newlines occur -- specifically# that verification commands are on single lines and that refresh and# garbage collection data are on multiple lines.############################################################################### Links: numbers, options#############################################################################global cmds, highlights, lastlen, alloccnt, alloctot, collectionsglobal mmunits, diagnose, namemaplink numbers, optionsprocedure main(args) local line, region, s, skip, opts opts := options(args,"dt") diagnose := if \opts["d"] then write else 1 display := if \opts["t"] then spread else report cmds := 'cefihLlRrSsTtux"XAF' # command characters highlights := '%$Y' # highlight commands mmunits := 4 # (for most systems) namemap := table("*** undefined ***") namemap["b"] := "large integer" namemap["c"] := "cset" namemap["e"] := "table element tv" namemap["f"] := "file" namemap["h"] := "hash block" namemap["i"] := "large integer" namemap["L"] := "list header" namemap["l"] := "list element" namemap["R"] := "record" namemap["r"] := "real number" namemap["S"] := "set header" namemap["s"] := "set element" namemap["T"] := "table header" namemap["t"] := "table element" namemap["u"] := "substring tv" namemap["x"] := "refresh block" namemap["\""] := "string" namemap["X"] := "co-expression" namemap["A"] := "alien block" namemap["F"] := "free space" lastlen := table() # last size alloccnt := table(0) # count of allocations alloctot := table(0) # total allocation collections := list(4,0) # garbage collection counts every alloccnt[!cmds] := 0 every alloctot[!cmds] := 0 cmds ++:= highlights while line := read() do { # input from MemMon history file line ? { # note: coded for extensions if region := tab(upto('{')) then { # skip refresh sequence collections[region] +:= 1 while line := read() | stop("**** premature eof") do line ? if upto('#!') then break next } case move(1) of { "=": next # skip verification command "#": next # skip comment ";": next # skip pause command "!" | ">": next # resynchronize (edited file) default: { # data to process move(-1) # back off from move(1) above if s := tab(upto('<')) then { mmunits := integer(s) # covers old case with no mmunits while line := read() | stop("**** premature eof") do line ? if upto('#>') then break next } else { repeat { # process allocation tab(many(' ')) # skip blanks (old files) if pos(0) then break next skip := process(tab(upto(cmds) + 1)) | stop("*** unexpected data: ",line) move(skip) } } } } } } display()end# Display a table of allocation data#procedure report() local cnt, cnttotal, i, tot, totalcoll, tottotal static col1, col2, gutter # column widths initial { col1 := 16 # name field col2 := 10 # number field gutter := repl(" ",6) } write(, # write column headings "\n", left("type",col1), right("number",col2), gutter, right("bytes",col2), gutter, right("average",col2), gutter, right("% bytes",col2), "\n" ) alloccnt := sort(alloccnt,3) # get the data alloctot := sort(alloctot,3) cnttotal := 0 tottotal := 0 ev 2 to *alloccnt by 2 do { cnttotal +:= alloccnt[i] tottotal +:= alloctot[i] } while write( # write the data left(namemap[get(alloccnt)],col1), # name right(cnt := get(alloccnt),col2), # number of allocations gutter, get(alloctot) & right(tot := get(alloctot),col2), # space allocated gutter, fix(tot,cnt,col2) | repl(" ",col2), gutter, fix(100.0 * tot,tottotal,col2) | repl(" ",col2) ) write( # write totals "\n", left("total:",col1), right(cnttotal,col2), gutter, right(tottotal,col2), gutter, fix(tottotal,cnttotal,col2) | repl(" ",col2) ) totalcoll := 0 # garbage collections every totalcoll +:= !collections write("\n",left("collections:",col1),right(totalcoll,col2)) if totalcoll > 0 then { write(left(" static region:",col1),right(collections[1],col2)) write(left(" string region:",col1),right(collections[2],col2)) write(left(" block region:",col1),right(collections[3],col2)) write(left(" no region:",col1),right(collections[4],col2)) } returnend# Produce tab-separated output for a spreadsheet.#procedure spread() alloccnt := sort(alloccnt,3) # get the data alloctot := sort(alloctot,3) write("*\nname number bytes") while write( # write the data namemap[get(alloccnt)], "\t", get(alloccnt), "\t", get(alloctot) & get(alloctot), ) returnend# Process datm#procedure process(s) local cmd, len s ? { tab(upto('+') + 1) # skip address len := tab(many(&digits)) | &null cmd := move(1) if cmd == !highlights then return 2 else { # if given len is nonstring, scale if cmd ~== "\"" then \len *:= mmunits alloccnt[cmd] +:= 1 (/len := lastlen[cmd]) | (lastlen[cmd] := len) diagnose(&errout,"cmd=",cmd,", len=",len) alloctot[cmd] +:= len return 0 } }end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldmiu.icn
############################################################################## Name: miu.icn## Title: Generate strings from the MIU system## Author: Cary A. Coutant, modified by Ralph E. Griswold## Date: December 27, 1989############################################################################### This program generates strings from the MIU string system.## The number of generations is determined by the command-line argument.# The default is 7.## Reference:## Godel, Escher, and Bach: an Eternal Golden Braid, Douglas R.# Hofstadter, Basic Books, 1979. pp. 33-36.#############################################################################procedure main(arg) local count, gen, limit count := 0 limit := integer(arg[1]) | 7 gen := ["MI"] every count := 1 to limit do { show(count,gen) gen := nextgen(gen) }end# show - show a generation of stringsprocedure show(count,gen) write("Generation #",count) every write(" ",image(\!gen)) write()end# nextgen - given a generation of strings, compute the next generationprocedure nextgen(gen) local new, s new := set() every insert(new,apply(!gen)) return sort(new)end# apply - produce all strings derivable from s in a single rule applicationprocedure apply(s) local i if s[-1] == "I" then suspend s || "U" if s[1] == "M" then suspend s || s[2:0] every i := find("III",s) do suspend s[1:i] || "U" || s[i+3:0] every i := find("UU",s) do suspend s[1:i] || s[i+2:0]end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldmonkeys.icn
############################################################################## Name: monkeys.icn## Title: Generate random text## Author: Stephen B. Wampler, modified by Ralph E. Griswold## Date: June 10, 1988############################################################################### The old monkeys at the typewriters anecdote ...# # This program uses ngram analysis to randomly generate text in# the same 'style' as the input text. The arguments are:# # -s show the input text# -n n use n as the ngram size (default:3)# -l n output at about n lines (default:10)# -r n set random number seed to n# ############################################################################## Links: options#############################################################################link optionsprocedure main(args) local switches, n, linecount, ngrams, preline local line, ngram, nextchar, firstngram, Show switches := options(args,"sn+l+r+") if \switches["s"] then Show := writes else Show := 1 n := \switches["n"] | 3 linecount := \switches["l"] | 10 ngrams := table() Show("Orginal Text is: \n\n") preline := "" every line := preline || !&input do { Show(line) line ? { while ngram := move(n) & nextchar := move(1) do { /firstngram := ngram /ngrams[ngram] := "" ngrams[ngram] ||:= nextchar move(-n) } preline := tab(0) || "\n" } } Show("\n\nGenerating Sentences\n\n") ngram := writes(firstngram) while linecount > 0 do { if /ngrams[ngram] then exit() # if hit EOF ngram early ngram := ngram[2:0] || writes(nextchar := ?ngrams[ngram]) if (nextchar == "\n") then linecount -:= 1 }end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldpack.icn
############################################################################## Name: pack.icn## Title: Package multiple files## Author: Ralph E. Griswold## Date: May 27, 1989############################################################################### This programs reads a list of file names from standard input and# packages the files into a single file, which is written to standard# output.## Files are separated by a header, ##########, followed by the file# name. This simple scheme does not work if a file contains such a header# itself, and it's problematical for files of binary data.############################################################################### See also: unpack.icn#############################################################################procedure main() local in while name := read() do { close(\in) in := open(name) | stop("cannot open input file: ",name) write("##########") write(name) while write(read(in)) }end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldparens.icn
############################################################################## Name: parens.icn## Title: Produce random parenthesis-balanced strings## Author: Ralph E. Griswold## Date: June 10, 1988############################################################################## # This program produces parenthesis-balanced strings in which# the parentheses are randomly distributed.# # Options: The following options are available:# # -b n Bound the length of the strings to n left and right# parentheses each. The default is 10.# # -n n Produce n strings. The default is 10.# # -l s Use the string s for the left parenthesis. The default# is ( .# # -r s Use the string s for the right parenthesis. The default# is ) .# # -v Randomly vary the length of the strings between 0 and# the bound. In the absence of this option, all strings# are the exactly as long as the specified bound.# # For example, the output for# # parens -v -b 4 -l "begin " -r "end "# # is# # begin end# begin end begin end# begin begin end end begin end# begin end begin begin end end# begin end# begin begin end end# begin begin begin end end end# begin end begin begin end end# begin end begin end# begin begin end begin end begin end end# # ents: This program was motivated by the need for test data# for error repair schemes for block-structured programming lan-# gauges. A useful extension to this program would be some# way of generating other text among the parentheses. In addition# to the intended use of the program, it can produce a variety of# interesting patterns, depending on the strings specified by -l# and -r.# ############################################################################## Links: options#############################################################################link optionsglobal r, k, lp, rpprocedure main(args) local string, i, s, bound, limit, varying, opts bound := limit := 10 # default bound and limit lp := "(" # default left paren rp := ")" # default right paren opts := options(args,"l:r:vb+n+") bound := \opts["b"] | 10 limit := \opts["n"] | 10 lp := \opts["l"] | "(" rp := \opts["r"] | ")" varying := opts["v"] every 1 to limit do { if \varying then k := 2 * ?bound else k := 2 * bound string := "" r := 0 while k ~= r do { if r = 0 then string ||:= Open() else if ?0 < probClose() then string ||:= Close() else string ||:= Open() } while k > 0 do string ||:= Close() write(string) }endprocedure Open() r +:= 1 k -:= 1 return lpendprocedure Close() r -:= 1 k -:= 1 return rpendprocedure probClose() return ((r * (r + k + 2)) / (2.0 * k * (r + 1)))end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldparse.icn
############################################################################## Name: parse.icn## Title: Parse simple statements## Author: Kenneth Walker## Date: December 22, 1989#############################################################################global lex # co-expression for lexical analyzerglobal next_tok # next token from inputrecord token(type, string)procedure main() lex := create ((!&input ? get_tok()) | |token("eof", "eof")) prog()end## get_tok is the main body of lexical analyzer#procedure get_tok() local tok repeat { # skip white space and comments tab(many(' ')) if ="#" | pos(0) then fail if any(&letters) then # determine token type tok := token("id", tab(many(&letters ++ '_'))) else if any(&digits) then tok := token("integer", tab(many(&digits))) else case move(1) of { ";" : tok := token("semi", ";") "(" : tok := token("lparen", "(") ")" : tok := token("rparen", ")") ":" : if ="=" then tok := token("assign", ":=") else tok := token("colon", ":") "+" : tok := token("add_op", "+") "-" : tok := token("add_op", "-") "*" : tok := token("mult_op", "*") "/" : tok := token("mult_op", "/") default : err("invalid character in input") } suspend tok }end## The procedures that follow make up the parser#procedure prog() next_tok := @lex stmt() while next_tok.type == "semi" do { next_tok := @lex stmt() } if next_tok.type ~== "eof" then err("eof expected")endprocedure stmt() if next_tok.type ~== "id" then err("id expected") write(next_tok.string) if (@lex).type ~== "assign" then err(":= expected") next_tok := @lex expr() write(":=")endprocedure expr() local op term() while next_tok.type == "add_op" do { op := next_tok.string next_tok := @lex term() write(op) }endprocedure term() local op factor() while next_tok.type == "mult_op" do { op := next_tok.string next_tok := @lex factor() write(op) }endprocedure factor() case next_tok.type of { "id" | "integer": { write(next_tok.string) next_tok := @lex } "lparen": { next_tok := @lex expr() if next_tok.type ~== "rparen" then err(") expected") else next_tok := @lex } default: err("id or integer expected") }endprocedure err(s) stop(" ** error ** ", s)end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldparsex.icn
############################################################################## Name: parsex.icn## Title: Parse arithmetic expressions## Author: Cheyenne Wills## Date: June 10, 1988############################################################################### Adapted from C code written by Allen I. Holub published in the# Feb 1987 issue of Dr. Dobb's Journal.## General purpose expression analyzer. Can evaluate any expression# consisting of number and the following operators (listed according# to precedence level):## () - ! 'str'str'# * / &# + -# < <= > >= == !=# && ||## All operators associate left to right unless () are present.# The top - is a unary minus.### <expr> ::= <term> <expr1># <expr1> ::= && <term> <expr1># ::= || <term> <expr1># ::= epsilon## <term> ::= <fact> <term1># <term1> ::= < <fact> <term1># ::= <= <fact> <term1># ::= > <fact> <term1># ::= >= <fact> <term1># ::= == <fact> <term1># ::= != <fact> <term1># ::= epsilon## <fact> ::= <part> <fact1># <fact1> ::= + <part> <fact1># ::= - <part> <fact1># ::= - <part> <fact1># ::= epsilon## <part> ::= <const> <part1># <part1> ::= * <const> <part1># ::= / <const> <part1># ::= % <const> <part1># ::= epsilon## <const> ::= ( <expr> )# ::= - ( <expr> )# ::= - <const># ::= ! <const># ::= 's1's2' # compares s1 with s2 0 if ~= else 1# ::= NUMBER # number is a lose term any('0123456789.Ee')##############################################################################procedure main() local line writes("->") while line := read() do { write(parse(line)) writes("->") }endprocedure parse(exp) return exp ? expr()endprocedure expr(exp) local lvalue lvalue := term() repeat { tab(many(' \t')) if ="&&" then lvalue := iand(term(),lvalue) else if ="||" then lvalue := ior(term(),lvalue) else break } return lvalueendprocedure term() local lvalue lvalue := fact() repeat { tab(many(' \t')) if ="<=" then lvalue := if lvalue <= fact() then 1 else 0 else if ="<" then lvalue := if lvalue < fact() then 1 else 0 else if =">=" then lvalue := if lvalue >= fact() then 1 else 0 else if =">" then lvalue := if lvalue > fact() then 1 else 0 else if ="==" then lvalue := if lvalue = fact() then 1 else 0 else if ="!=" then lvalue := if lvalue ~= fact() then 1 else 0 else break } return lvalueendprocedure fact() local lvalue lvalue := part() repeat { tab(many(' \t')) if ="+" then lvalue +:= part() else if ="-" then lvalue -:= part() else break } return lvalueendprocedure part() local lvalue lvalue := const() repeat { tab(many(' \t')) if ="*" then lvalue *:= part() else if ="%" then lvalue %:= part() else if ="/" then lvalue /:= part() else break } return lvalueendprocedure const() local sign, logical, rval, s1, s2 tab(many(' \t')) if ="-" then sign := -1 else sign := 1 if ="!" then logical := 1 else logical := &null if ="(" then { rval := expr() if not match(")") then { write(&subject) write(right("",&pos-1,"_"),"^ Mis-matched parenthesis") } else move(1) } else if ="'" then { s1 := tab(upto('\'')) move(1) s2 := tab(upto('\'')) move(1) rval := if s1 === s2 then 1 else 0 } else { rval := tab(many('0123456789.eE')) } if \logical then { return if rval = 0 then 1 else 0 } else return rval * signend :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldpress.icn
############################################################################## Name: press.icn## Title: LZW Compression and Decompression Utility## Author: Robert J. Alexander## Date: December 5, 1989############################################################################### Note: This program is designed primarily to demonstrate the LZW# compression process. It contains a lot of tracing toward# that end and is too slow for practical use.############################################################################### Usage: press [-t] -c [-s n] [-f <compressed file>] <file to compress>...# press [-t] -x <compressed file>...## -c perform compression# -x expand (decompress) compressed file# -f output file for compression -- if missing standard output used# -s maximum string table size# (for compression only -- default = 1024)# -t output trace info to standard error file## If the specified maximum table size is positive, the string table is# discarded when the maximum size is reached and rebuilt (recommended).# If negative, the original table is not discarded, which might produce# better results in some circumstances.############################################################################### Features that might be nice to add someday:## Allow decompress output to standard output.## Handle heirarchies.## Way to list files in archive, and access individual files############################################################################### Links: options#############################################################################global inchars,outchars,tinchars,toutchars,lzw_recycles, lzw_stringTable,lzw_trace,wr,wrs,rf,wflink optionsprocedure main(arg) local compr,expand,fn,maxT,maxTableSize,opt,outfile,wfn # # Initialize. # opt := options(arg,"ts+f:cx") if *arg = 0 then arg := ["-"] lzw_trace := opt["t"] expand := opt["x"] compr := opt["c"] outfile := opt["f"] maxTableSize := \opt["s"] if (/expand & /compr) then Usage() wr := write ; wrs := writes inchars := outchars := tinchars := toutchars := lzw_recycles := 0 # # Process compression. # if \compr then { if \expand then Usage() if \outfile then wf := open(outfile,"w") | stop("Can't open output file ",outfile) # # Loop to process files on command line. # every fn := !arg do { if fn === outfile then next wr(&errout,"\nFile \"",fn,"\"") rf := if fn ~== "-" then open(fn) | &null else &input if /rf then { write(&errout,"Can't open input file \"",fn,"\" -- skipped") next } write(wf,tail(fn)) maxT := compress(r,w,maxTableSize) close(rf) stats(maxT) } } # # Process decompression. # else if \expand then { if \(compr | outfile | maxTableSize) then Usage() # # Loop to process files on command line. # every fn := !arg do { rf := if fn ~== "-" then open(fn) | &null else &input if /rf then { write(&errout,"Can't open input file \"",fn,"\" -- skipped") next } while wfn := read(rf) do { wr(&errout,"\nFile \"",wfn,"\"") wf := open(wfn,"w") | &null if /wf then { write(&errout,"Can't open output file \"",wfn,"\" -- quitting") exit(1) } maxT := decompress(r,w) close(wf) stats(maxT) } close(rf) } } else Usage() # # Write statistics # wr(&errout,"\nTotals: ", "\n input = ",tinchars, "\n output = ",toutchars, "\n compression factor = ",(real(toutchars) / real(0 < tinchars)) | "")endprocedure stats(maxTableSize) # # Write statistics # wr(&errout, " input = ",inchars, "\n output = ",outchars, "\n compression factor = ",(real(outchars) / real(0 < inchars)) | "", "\n table size = ",*lzw_stringTable,"/",maxTableSize, " (",lzw_recycles," recycles)") tinchars +:= inchars toutchars +:= outchars inchars := outchars := lzw_recycles := 0 returnendprocedure r() return 1(reads(rf),inchars +:= 1)endprocedure w(s) return 1(writes(wf,s),outchars +:= *s)endprocedure Usage() stop("_# Usage: icompress [-t] -c [-s n] <file to compress>...\n_# icompress [-t] -x <compressed file>...\n_#\n_# -c perform compression\n_# -x expand (decompress) compressed file\n_# -f output file for compression -- if missing standard output used\n_# -s maximum string table size\n_# (for compression only -- default = 1024)\n_# -t output trace info to standard error file\n_#")endprocedure tail(fn) local i i := 0 every i := find("/",fn) return fn[i + 1:0]end## compress() -- LZW compression## Arguments:## inproc a procedure that returns a single character from# the input stream.## outproc a procedure that writes a single character (its# argument) to the output stream.## maxTableSize the maximum size to which the string table# is allowed to grow before something is done about it.# If the size is positive, the table is discarded and# a new one started. If negative, it is retained, but# no new entries are added.#procedure compress(inproc,outproc,maxTableSize) local EOF,c,charTable,junk1,junk2,outcode,s,t, tossTable,x # # Initialize. # /maxTableSize := 1024 # 10 "bits" every outproc(!string(maxTableSize)) outproc("\n") tossTable := maxTableSize /lzw_recycles := 0 if maxTableSize < 0 then maxTableSize := -maxTableSize charTable := table() every c := !&cset do charTable[c] := ord(c) EOF := charTable[*charTable] := *charTable # reserve code=256 for EOF lzw_stringTable := copy(charTable) # # Compress the input stream. # s := inproc() | return maxTableSize if \lzw_trace then { wr(&errout,"\nInput string\tOutput code\tNew table entry") wrs(&errout,"\"",image(s)[2:-1]) } while c := inproc() do { if \lzw_trace then wrs(&errout,image(c)[2:-1]) if \lzw_stringTable[t := s || c] then s := t else { compress_output(outproc,junk2 := lzw_stringTable[s],junk1 := *lzw_stringTable) if *lzw_stringTable < maxTableSize then lzw_stringTable[t] := *lzw_stringTable else if tossTable >= 0 then { lzw_stringTable := copy(charTable) lzw_recycles +:= 1 } if \lzw_trace then wrs(&errout,"\"\t\t", image(char(*&cset > junk2) | junk2), "(",junk1,")\t\t",lzw_stringTable[t]," = ",image(t),"\n\"") s := c } } compress_output(outproc,lzw_stringTable[s],*lzw_stringTable) if \lzw_trace then wr(&errout,"\"\t\t", image(char(*&cset > (x := \lzw_stringTable[s] | 0)) | x)) compress_output(outproc,EOF,*lzw_stringTable) compress_output(outproc) return maxTableSizeendprocedure compress_output(outproc,code,stringTableSize) local outcode static max,bits,buffer,bufferbits,lastSize # # Initialize. # initial { lastSize := 1000000 buffer := bufferbits := 0 } # # If this is "close" call, flush buffer and reinitialize. # if /code then { outcode := &null if bufferbits > 0 then outproc(char(outcode := ishift(buffer,8 - bufferbits))) lastSize := 1000000 buffer := bufferbits := 0 return outcode } # # Expand output code size if necessary. # if stringTableSize < lastSize then { max := 1 bits := 0 } while stringTableSize > max do { max *:= 2 bits +:= 1 } lastSize := stringTableSize # # Merge new code into buffer. # buffer := ior(ishift(buffer,bits),code) bufferbits +:= bits # # Output bits. # while bufferbits >= 8 do { outproc(char(outcode := ishift(buffer,8 - bufferbits))) buffer := ixor(buffer,ishift(outcode,bufferbits - 8)) bufferbits -:= 8 } return outcodeend############################################################################## decompress() -- LZW decompression of compressed stream created# by compress()## Arguments:## inproc a procedure that returns a single character from# the input stream.## outproc a procedure that writes a single character (its# argument) to the output stream.#procedure decompress(inproc,outproc) local EOF,c,charSize,code,i,maxTableSize,new_code,old_strg, strg,tossTable # # Initialize. # maxTableSize := "" while (c := inproc()) ~== "\n" do maxTableSize ||:= c maxTableSize := integer(maxTableSize) | stop("Invalid file format -- max table size missing") tossTable := maxTableSize /lzw_recycles := 0 if maxTableSize < 0 then maxTableSize := -maxTableSize maxTableSize -:= 1 lzw_stringTable := list(*&cset) every i := 1 to *lzw_stringTable do lzw_stringTable[i] := char(i - 1) put(lzw_stringTable,EOF := *lzw_stringTable) # reserve code=256 for EOF charSize := *lzw_stringTable if \lzw_trace then wr(&errout,"\nInput code\tOutput string\tNew table entry") # # Decompress the input stream. # while old_strg := lzw_stringTable[decompress_read_code(inproc,*lzw_stringTable,EOF) + 1] do { if \lzw_trace then wr(&errout,image(old_strg),"(",*lzw_stringTable,")", "\t",image(old_strg)) outproc(old_strg) c := old_strg[1] (while new_code := decompress_read_code(inproc,*lzw_stringTable + 1,EOF) do { strg := lzw_stringTable[new_code + 1] | old_strg || c outproc(strg) c := strg[1] if \lzw_trace then wr(&errout,image(char(*&cset > new_code) \ 1 | new_code), "(",*lzw_stringTable + 1,")","\t", image(strg),"\t\t", *lzw_stringTable," = ",image(old_strg || c)) if *lzw_stringTable < maxTableSize then put(lzw_stringTable,old_strg || c) else if tossTable >= 0 then { lzw_stringTable := lzw_stringTable[1:charSize + 1] lzw_recycles +:= 1 break } old_strg := strg }) | break # exit outer loop if this loop completed } decompress_read_code() return maxTableSizeendprocedure decompress_read_code(inproc,stringTableSize,EOF) local code static max,bits,buffer,bufferbits,lastSize # # Initialize. # initial { lastSize := 1000000 buffer := bufferbits := 0 } # # Reinitialize if called with no arguments. # if /inproc then { lastSize := 1000000 buffer := bufferbits := 0 return } # # Expand code size if necessary. # if stringTableSize < lastSize then { max := 1 bits := 0 } while stringTableSize > max do { max *:= 2 bits +:= 1 } # # Read in more data if necessary. # while bufferbits < bits do { buffer := ior(ishift(buffer,8),ord(inproc())) | stop("Premature end of file") bufferbits +:= 8 } # # Extract code from buffer and return. # code := ishift(buffer,bits - bufferbits) buffer := ixor(buffer,ishift(code,bufferbits - bits)) bufferbits -:= bits return EOF ~= codeend :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldproto.icn
############################################################################## Name: proto.icn## Title: Instances of different syntactic forms in Icon## Author: Ralph E. Griswold## Date: June 10, 1988############################################################################### This program doesn't "do" anything. It just contains an example of# every syntactic form in Version 7 of Icon (or close to it). It might# be useful for checking programs that process Icon programs. Note, however,# that it does not contain many combinations of different syntactic forms.############################################################################### Program note:## This program is divided into procedures to avoid overflow with# default values for Icon's translator and linker.############################################################################### Links: options## Requires: co-expressions#############################################################################link optionsrecord three(x,y,z)record zero()record one(z)global line, countprocedure main() expr1() expr2() expr3() expr4(1,2) expr4{1,2} expr5(1,2,3,4)endprocedure expr1() local x, y, z local i, j static e1 initial e1 := 0 exit() # get out before there's trouble () {} ();() [] [,] x.y x[i] x[i:j] x[i+:j] x[i-:j] (,,,) x(,,,) not x |x !x *x +x -xendprocedure expr2() local x, i, y, j, c1, c2, s1, s2, a2, k, a1 .x /x =x ?x \x ~x @x ^x x \ i x @ y i ^ j i * j i / j i % j c1 ** c2 i + j i - j c1 ++ c2 c1 -- c2 s1 || s2 a1 ||| a2 i < j i <= j i = j i >= j i > j i ~= j s1 << s2 s1 == s2 s1 >>= s2 s1 >> s2 s1 ~== s2 x === y x ~=== y x | y i to j i to j by k x := y x <- y x :=: y x <-> y i +:= j i -:= j i *:= jendprocedure expr3() local i, j, c1, c2, s1, s2, a1, a2, x, y, s i /:= j i %:= j i ^:= j i <:= j i <=:= j i =:= j i >=:= j i ~=:= j c1 ++:= c2 c1 --:= c2 c1 **:= c2 s1 ||:= s2 s1 <<:= s2 s1 <<=:= s2 s1 ==:= s2 s1 >>=:= s2 s1 >>:= s2 s1 ~==:= s2 s1 ?:= s2 a1 |||:= a2 x ===:= y x ~===:= y x &:= y x @:= y s ? x x & y create x return return x suspend x suspend x do y failendprocedure expr4() local e1, e2, e, x, i, j, size, s, e3, X_ while e1 do break while e1 do break e2 while e1 do next case e of { x: fail (i > j) | 1 : return } case size(s) of { 1: 1 default: fail } if e1 then e2 if e1 then e2 else e3 repeat e while e1 while e1 do e2 until e1 until e1 do e2 every e1 every e1 do e2 x X_ &cset &null "abc" "abc_ cde" 'abc' 'abc_ cde' "\n" "^a" "\001" "\x01" 1 999999 36ra1 3.5 2.5e4 4e-10endprocedure expr5(a,b,c[])end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldqueens.icn
############################################################################## Name: queens.icn## Title: Generate solutions to the n-queens problem## Author: Stephen B. Wampler## Date: June 10, 1988############################################################################## # This program displays the solutions to the non-attacking n-# queens problem: the ways in which n queens can be placed on an# n-by-n chessboard so that no queen can attack another. A positive# integer can be given as a command line argument to specify the# number of queens. For example,# # iconx queens -n8# # displays the solutions for 8 queens on an 8-by-8 chessboard. The# default value in the absence of an argument is 6. One solution# for six queens is:# # -------------------------# | | Q | | | | |# -------------------------# | | | | Q | | |# -------------------------# | | | | | | Q |# -------------------------# | Q | | | | | |# -------------------------# | | | Q | | | |# -------------------------# | | | | | Q | |# -------------------------# # Comments: There are many approaches to programming solutions to# the n-queens problem. This program is worth reading for# its programming techniques.# ############################################################################## Links: options#############################################################################link optionsglobal n, solutionprocedure main(args) local i, opts opts := options(args,"n+") n := \opts["n"] | 6 if n <= 0 then stop("-n needs a positive numeric parameter") solution := list(n) # ... and a list of column solutions write(n,"-Queens:") every q(1) # start by placing queen in first columnend# q(c) - place a queen in column c.#procedure q(c) local r static up, down, rows initial { up := list(2*n-1,0) down := list(2*n-1,0) rows := list(n,0) } every 0 = rows[r := 1 to n] = up[n+r-c] = down[r+c-1] & rows[r] <- up[n+r-c] <- down[r+c-1] <- 1 do { solution[c] := r # record placement. if c = n then show() else q(c + 1) # try to place next queen. }end# show the solution on a chess board.#procedure show() static count, line, border initial { count := 0 line := repl("| ",n) || "|" border := repl("----",n) || "-" } write("solution: ", count+:=1) write(" ", border) every line[4*(!solution - 1) + 3] <- "Q" do { write(" ", line) write(" ", border) } write()end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldrecgen.icn
############################################################################## Name: recgen.icn## Title: Generate recognizer for sentences in a context-free language## Author: Ralph E. Griswold## Date: June 10, 1988############################################################################### This program reads a context-free grammar and produces an Icon# program that is a recognizer for the corresponding language.## Nonterminal symbols are represented by uppercase letters. Vertical# bars separate alternatives. All other characters are considered to# be terminal symbols. The nonterminal symbol on the last line is# taken to be the goal.## An example is:## X::=T|T+X# T::=E|E*T# E::=x|y|z|(X)## Limitations:## Left recursion in the grammar may cause the recognizer to loop.# There is no check that all nonterminal symbols that are referenced# are defined.## Reference:## The Icon Programming Language, Ralph E. and Madge T. Griswold,# Prentice-Hall, 1983. pp. 161-165.#############################################################################global goalprocedure main() local line, sym while line := read() do define(line) write("\nprocedure main()") write(" while line := read() do {") write(" writes(image(line))") write(" if line ? (",goal,"() & pos(0)) then _ write(\": accepted\")\n else write(\": rejected\")") write(" }") write("end")endprocedure expand(s,x) local s1, sym s1 := "" s ? while sym := move(1) do if any(&ucase,sym) then s1 ||:= sym || "() || " else s1 ||:= "=\"" || sym || "\" || " return s1[1:-4]endprocedure define(line) line ? ( write("\nprocedure ",goal := move(1),"()"), ="::=", write(" suspend {"), (every write(" ",prodlist())) | "", write(" }"), write("end") )endprocedure prodlist() local p while p := expand(tab(many(~'|')),"=") do { move(1) | return "(" || p || ")" # last alternative suspend "(" || p || ") |" }end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldroffcmds.icn
############################################################################## Name: roffcmds.icn## Title: List commands and macros in a roff document## Author: Ralph E. Griswold## Date: June 10, 1988############################################################################## # This progam processes standard input and writes a tabulation of# nroff/troff commands and defined strings to standard output.# # Limitations:# # This program only recognizes commands that appear at the beginning of# lines and does not attempt to unravel conditional constructions.# Similarly, defined strings buried in disguised form in definitions are# not recognized.# # Reference:# # Nroff/Troff User's Manual, Joseph F. Ossana, Bell Laboratories,# Murray Hill, New Jersey. October 11, 1976.# ########################################################################ocedure main() local line, con, mac, y, nonpuncs, i, inname, infile, outname, outfile nonpuncs := ~'. \t\\' con := table(0) mac := table(0) while line := read() do { line ? if tab(any('.\'')) then con[tab(any(nonpuncs)) || (tab(upto(' ') | 0))] +:= 1 line ? while tab((i := find("\\")) + 1) do { case move(1) of { "(": move(2) "*" | "f" | "n": if ="(" then move(2) else move(1) } mac[&subject[i:&pos]] +:= 1 } } con := sort(con,3) write(,"Commands:\n") while write(,get(con),"\t",get(con)) mac := sort(mac,3) write(,"\nControls:\n") while write(,get(mac),"\t",get(mac))end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldrsg.icn
############################################################################## Name: rsg.icn## Title: Generate randomly selected sentences from a grammar## Author: Ralph E. Griswold## Date: June 10, 1988############################################################################## # This program generates randomly selected strings (``sen-# tences'') from a grammar specified by the user. Grammars are# basically context-free and resemble BNF in form, although there# are a number of extensions.# # The program works interactively, allowing the user to build,# test, modify, and save grammars. Input to rsg consists of various# kinds of specifications, which can be intermixed:# # Productions define nonterminal symbols in a syntax similar to# the rewriting rules of BNF with various alternatives consisting# of the concatenation of nonterminal and terminal symbols. Gen-# eration specifications cause the generation of a specified number# of sentences from the language defined by a given nonterminal# symbol. Grammar output specifications cause the definition of a# specified nonterminal or the entire current grammar to be written# to a given file. Source specifications cause subsequent input to# be read from a specified file.# # In addition, any line beginning with # is considered to be a# comment, while any line beginning with = causes the rest of that# line to be used subsequently as a prompt to the user whenever rsg# is ready for input (there normally is no prompt). A line consist-# ing of a single = stops prompting.# # Productions: Examples of productions are:# # <expr>::=<term>|<term>+<expr># <term>::=<elem>|<elem>*<term># <elem>::=x|y|z|(<expr>)# # Productions may occur in any order. The definition for a nonter-# minal symbol can be changed by specifying a new production for# it.# # There are a number of special devices to facilitate the defin-# ition of grammars, including eight predefined, built-in nontermi-# nal symbols:# symbol definition# <lb> <# <rb> ># <vb> |# <nl> newline# <> empty string# <&lcase> any single lowercase letter# <&ucase> any single uppercase letter# <&digit> any single digit# # In addition, if the string between a < and a > begins and ends# with a single quotation mark, it stands for any single character# between the quotation marks. For example,# # <'xyz'># # is equivalent to# # x|y|z# # GenSpecifications: A generation specification consists of# a nonterminal symbol followed by a nonnegative integer. An exam-# ple is# # <expr>10# # which specifies the generation of 10 <expr>s. If the integer is# omitted, it is assumed to be 1. Generated sentences are written# to standard output.# # Grammar Output Specifications: A grammar output specification# consists of a nonterminal symbol, followed by ->, followed by a# file name. Such a specification causes the current definition of# the nonterminal symbol to be written to the given file. If the# file is omitted, standard output is assumed. If the nonterminal# symbol is omitted, the entire grammar is written out. Thus,# # -># # causes the entire grammar to be written to standard output.# # Source Specifications: A source specification consists of @ fol-# lowed by a file name. Subsequent input is read from that file.# When an end of file is encountered, input reverts to the previous# file. Input files can be nested.# # Options: The following options are available:# # -s n Set the seed for random generation to n. The default# seed is 0.# # -l n Terminate generation if the number of symbols remaining# to be processed exceeds n. The default is limit is 1000.# # -t Trace the generation of sentences. Trace output goes to# standard error output.# # Diagnostics: Syntactically erroneous input lines are noted but# are otherwise ignored. Specifications for a file that cannot be# opened are noted and treated as erroneous.# # If an undefined nonterminal symbol is encountered during gen-# eration, an error message that identifies the undefined symbol is# produced, followed by the partial sentence generated to that# point. Exceeding the limit of symbols remaining to be generated# as specified by the -l option is handled similarly.# # Caveats: Generation may fail to terminate because of a loop in# the rewriting rules or, more seriously, because of the progres-# sive accumulation of nonterminal symbols. The latter problem can# be identified by using the -t option and controlled by using the# -l option. The problem often can be circumvented by duplicating# alternatives that lead to fewer rather than more nonterminal sym-# bols. For example, changing# # <term>::=<elem>|<elem>*<term># # to# # <term>::=<elem>|<elem>|<elem>*<term># # increases the probability of selecting <elem> from 1/2 to 2/3.# # There are many possible extensions to the program. One of the# most useful would be a way to specify the probability of select-# ing an alternative.# ############################################################################## Links: options#############################################################################link optionsglobal defs, ifile, in, limit, prompt, tswitchrecord nonterm(name)record charset(chars)procedure main(args) local line, plist, s, opts # procedures to try on input lines plist := [define,generate,grammar,source,comment,prompter,error] defs := table() # table of definitions defs["lb"] := [["<"]] # built-in definitions defs["rb"] := [[">"]] defs["vb"] := [["|"]] defs["nl"] := [["\n"]] defs[""] := [[""]] defs["&lcase"] := [[charset(&lcase)]] defs["&ucase"] := [[charset(&ucase)]] defs["&digit"] := [[charset(&digits)]] opts := options(args,"tl+s+") limit := \opts["l"] | 1000 tswitch := \opts["t"] &random := \opts["s"] ifile := [&input] # stack of input files prompt := "" while in := pop(ifile) do { # process all files repeat { if *prompt ~= 0 then writes(prompt) line := read(in) | break while line[-1] == "\\" do line := line[1:-1] || read(in) | break (!plist)(line) } close(in) }end# process alternatives#procedure alts(defn) local alist alist := [] defn ? while put(alist,syms(tab(upto('|') | 0))) do move(1) | break return alistend# look for comment#procedure comment(line) if line[1] == "#" then returnend# look for definition#procedure define(line) return line ? defs[(="<",tab(find(">::=")))] := (move(4),alts(tab(0)))end# define nonterminal#procedure defnon(sym) local chars, name if sym ? { ="'" & chars := cset(tab(-1)) & ="'" } then return charset(chars) else return nonterm(sym)end# note erroneous input line#procedure error(line) write("*** erroneous line: ",line) returnend# generate sentences#procedure gener(goal) local pending, symbol pending := [nonterm(goal)] while symbol := get(pending) do { if \tswitch then write(&errout,symimage(symbol),listimage(pending)) case type(symbol) of { "string": writes(symbol) "charset": writes(?symbol.chars) "nonterm": { pending := ?\defs[symbol.name] ||| pending | { write(&errout,"*** undefined nonterminal: <",symbol.name,">") break } if *pending > \limit then { write(&errout,"*** excessive symbols remaining") break } } } } write()end# look for generation specification#procedure generate(line) local goal, count if line ? { ="<" & goal := tab(upto('>')) \ 1 & move(1) & count := (pos(0) & 1) | integer(tab(0)) } then { every 1 to count do gener(goal) return } else failend# get right hand side of production#procedure getrhs(a) local rhs rhs := "" every rhs ||:= listimage(!a) || "|" return rhs[1:-1]end# look for request to write out grammar#procedure grammar(line) local file, out, name if line ? { name := tab(find("->")) & move(2) & file := tab(0) & out := if *file = 0 then &output else { open(file,"w") | { write(&errout,"*** cannot open ",file) fail } } } then { (*name = 0) | (name[1] == "<" & name[-1] == ">") | fail pwrite(name,out) if *file ~= 0 then close(out) return } else failend# produce image of list of grammar symbols#procedure listimage(a) local s, x s := "" every x := !a do s ||:= symimage(x) return send# look for new prompt symbol#procedure prompter(line) if line[1] == "=" then { prompt := line[2:0] return }end# write out grammar#procedure pwrite(name,ofile) local nt, a static builtin initial builtin := ["lb","rb","vb","nl","","&lcase","&ucase","&digit"] if *name = 0 then { a := sort(defs,3) while nt := get(a) do { if nt == !builtin then { get(a) next } write(ofile,"<",nt,">::=",getrhs(get(a))) } } else write(ofile,name,"::=",getrhs(\defs[name[2:-1]])) | write("*** undefined nonterminal: ",name)end# look for file with input#procedure source(line) local file, new return line ? { if ="@" then { new := open(file := tab(0)) | { write(&errout,"*** cannot open ",file) fail } push(ifile,in) & in := new return } }end# produce string image of grammar symbol#procedure symimage(x) return case type(x) of { "string": x "nonterm": "<" || x.name || ">" "charset": "<'" || x.chars || "'>" }end# process the symbols in an alternative#procedure syms(alt) local slist static nonbrack initial nonbrack := ~'<' slist := [] alt ? while put(slist,tab(many(nonbrack)) | defnon(2(="<",tab(upto('>')),move(1)))) return slistend :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldruler.icn
############################################################################## Name: ruler.icn## Title: Write a character ruler to standard output## Author: Robert J. Alexander## Date: December 5, 1989############################################################################### Write a character ruler to standard output. The first optional# argument is the length of the ruler in characters (default 80).# The second is a number of lines to write, with a line number on# each line.#procedure main(arg) local length, ruler, lines, i length := "" ~== arg[1] | 80 every writes(right(1 to length / 10,10)) ruler := right("",length,"----+----|") if lines := arg[2] then { write() every i := 2 to lines do write(i,ruler[*i + 1:0]) } else write("\n",ruler)end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldshuffile.icn
############################################################################## Name: shuffile.icn## Title: Shuffle lines in a file## Author: Ralph E. Griswold## Date: June 10, 1988############################################################################## # This program writes a version of the input file with the lines# shuffled. For example, the result of shuffling# # On the Future!-how it tells# Of the rapture that impells# To the swinging and the ringing# Of the bells, bells, bells-# Of the bells, bells, bells, bells,# Bells, bells, bells-# To the rhyming and the chiming of the bells!# # is# # To the rhyming and the chiming of the bells!# To the swinging and the ringing# Bells, bells, bells-# Of the bells, bells, bells-# On the Future!-how it tells# Of the bells, bells, bells, bells,# Of the rapture that impells# # Option: The option -s n sets the seed for random generation to n.# The default seed is 0.# # Limitation:## This program stores the input file in memory and# shuffles pointers to the lines; there must be enough memory# available to store the entire file.# ############################################################################## Links: options, shuffle#############################################################################link options, shuffleprocedure main(args) local opts, a opts := options(args, "s+") &random := \opts["s"] a := [] every put(a,!&input) every write(!shuffle(a))end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldsolit.icn
############################################################################## Name: solit.icn## Title: Play the game of solitaire## Author: Jerry Nowlin## Date: June 10, 1988############################################################################## # This program was inspired by a solitaire game that was written# by Allyn Wade and copyrighted by him in 1985. His game was# designed for the IBM PC/XT/PCjr with a color or monochrome moni-# tor.# # I didn't follow his design exactly because I didn't want to# restrict myself to a specific machine. This program has the# correct escape sequences programmed into it to handle several# common terminals and PC's. It's commented well enough that most# people can modify the source to work for their hardware.# # These variables must be defined with the correct escape# sequences to:# # CLEAR - clear the screen# CLREOL - clear to the end of line# NORMAL - turn on normal video for foreground characters# RED - make the foreground color for characters red# BLACK - make the foreground color for characters black# # If there is no way to use red and black, the escape sequences# should at least make RED and BLACK have different video attri-# butes; for example red could have inverse video while black has# normal video.# # There are two other places where the code is device dependent.# One is in the face() procedure. The characters used to display# the suites of cards can be modified there. For example, the IBM# PC can display actual card face characters while all other# machines currently use HDSC for hearts, diamonds, spades and# clubs respectively.# # The last, and probably trickiest place is in the movecursor()# procedure. This procedure must me modified to output the correct# escape sequence to directly position the cursor on the screen.# The comments and 3 examples already in the procedure will help.# # So as not to cast dispersions on Allyn Wade's program, I# incorporated the commands that will let you cheat. They didn't# exist in his program. I also incorporated the auto pilot command# that will let the game take over from you at your request and try# to win. I've run some tests, and the auto pilot can win about# 10% of the games it's started from scratch. Not great but not# too bad. I can't do much better myself without cheating. This# program is about as totally commented as you can get so the logic# behind the auto pilot is fairly easy to understand and modify.# It's up to you to make the auto pilot smarter.# ############################################################################## Note:## The command-line argument, which defaults to support for the VT100,# determines the screen driver. For MS-DOS computers, the ANSI.SYS driver# is needed.# ############################################################################global VERSION, CLEAR, CLREOL, NORMAL, RED, BLACKglobal whitespace, amode, seed, deck, over, hidden, run, aceprocedure main(args) local a, p, c, r, s, cnt, cheat, cmd, act, from, dest VERSION := (!args == ("Atari ST" | "hp2621" | "IBM PC" | "vt100")) case VERSION of { "Atari ST": { CLEAR := "\eE" CLREOL := "\eK" NORMAL := "\eb3" RED := "\eb1" BLACK := "\eb2" } "hp2621": { CLEAR := "\eH\eJ" CLREOL := "\eK" NORMAL := "\e&d@" RED := "\e&dJ" BLACK := "\e&d@" } "IBM PC" | "vt100": { CLEAR := "\e[H\e[2J" CLREOL := "\e[0K" NORMAL := "\e[0m" RED := "\e[31m" BLACK := "\e[34m" } default: { # same as IBM PC and vt100 CLEAR := "\e[H\e[2J" CLREOL := "\e[0K" NORMAL := "\e[0m" RED := "\e[31m" BLACK := "\e[34m" } } # white space is blanks or tabs whitespace := ' \t' # clear the auto pilot mode flag amode := 0 # if a command line argument started with "seed" use the rest of # the argument for the random number generator seed value if (a := !args)[1:5] == "seed" then seed := integer(a[5:0]) # initialize the data structures deck := shuffle() over := [] hidden := [[],[],[],[],[],[],[]] run := [[],[],[],[],[],[],[]] ace := [[],[],[],[]] # lay down the 7 piles of cards every p := 1 to 7 do every c := p to 7 do put(hidden[c],get(deck)) # turn over the top of each pile to start a run every r := 1 to 7 do put(run[r],get(hidden[r])) # check for aces in the runs and move them to the ace piles every r := 1 to 7 do while getvalue(run[r][1]) = 1 do { s := getsuite(!run[r]) push(ace[s],get(run[r])) put(run[r],get(hidden[r])) } # initialize the command and cheat counts cnt := cheat := 0 # clear the screen and display the initial layout writes(CLEAR) display() # if a command line argument was "auto" let the auto pilot take over if !args == "auto" then autopilot() # loop reading commands repeat { # increment the command count cnt +:= 1 # prompt for a command movecursor(15,0) writes("cmd:",cnt,"> ",CLREOL) # scan the command line (cmd := read() | exit()) ? { # parse the one character action tab(many(whitespace)) act := (move(1) | "") tab(many(whitespace)) # switch on the action case act of { # turn on the automatic pilot "a": autopilot() # move a card or run of cards "m": { from := move(1) | whoops(cmd) tab(many(whitespace)) dest := move(1) | whoops(cmd) if not movecard(from,dest) then whoops(cmd) else if cardsleft() = 0 then finish(cheat) else &null } # thumb the deck "t" | "": thumb() # print some help "h" | "?": disphelp() # print the rules of the game "r": disprules() # give up without winning "q": break # shuffle the deck (cheat!) "s": { deck |||:= over over := [] deck := shuffle(deck) display(["deck"]) cheat +:= 1 } # put hidden cards in the deck (cheat!) "p": { from := move(1) | whoops(cmd) if integer(from) & from >= 2 & from <= 7 & *hidden[from] > 0 then { deck |||:= hidden[from] hidden[from] := [] display(["hide","deck"]) cheat +:= 1 } else { whoops(cmd) } } # print the contents of the deck (cheat!) "d": { movecursor(17,0) write(*deck + *over," cards in deck:") every writes(face(deck[*deck to 1 by -1])," ") every writes(face(!over)," ") writes("\nHit RETURN") read() movecursor(17,0) every 1 to 4 do write(CLREOL) cheat +:= 1 } # print the contents of a hidden pile (cheat!) "2" | "3" | "4" | "5" | "6" | "7": { movecursor(17,0) write(*hidden[act]," cards hidden under run ", act) every writes(face(!hidden[act])," ") writes("\nHit RETURN") read() movecursor(17,0) every 1 to 4 do write(CLREOL) cheat +:= 1 } # they gave an invalid command default: whoops(cmd) } # end of action case } # end of scan line } # end of command loop # a quit command breaks the loop movecursor(16,0) writes(CLREOL,"I see you gave up") if cheat > 0 then write("...even after you cheated ",cheat," times!") else write("...but at least you didn't cheat...congratulations!") exit(1)end# this procedure moves cards from one place to anotherprocedure movecard(from,dest,limitmove) # if from and dest are the same fail if from == dest then fail # move a card from the deck if from == "d" then { # to one of the aces piles if dest == "a" then { return deck2ace() # to one of the 7 run piles } else if integer(dest) & dest >= 1 & dest <= 7 then { return deck2run(dest) } # from one of the 7 run piles } else if integer(from) & from >= 1 & from <= 7 then { # to one of the aces piles if dest == "a" then { return run2ace(from) # to another of the 7 run piles } else if integer(dest) & dest >= 1 & dest <= 7 then { return run2run(from,dest,limitmove) } } # if none of the correct move combinations were found fail failendprocedure deck2run(dest) local fcard, dcard, s # set fcard to the top of the overturned pile or fail fcard := (over[1] | fail) # set dcard to the low card of the run or to null if there are no # cards in the run dcard := (run[dest][-1] | &null) # check to see if the move is legal if chk2run(fcard,dcard) then { # move the card and update the display put(run[dest],get(over)) display(["deck",dest]) # while there are aces on the top of the overturned pile # move them to the aces piles while getvalue(over[1]) = 1 do { s := getsuite(over[1]) push(ace[s],get(over)) display(["deck","ace"]) } return }endprocedure deck2ace() local fcard, a, s # set fcard to the top of the overturned pile or fail fcard := (over[1] | fail) # for every ace pile every a := !ace do { # if the top of the ace pile is one less than the from card # they are in the same suit and in sequence if a[-1] + 1 = fcard then { # move the card and update the display put(a,get(over)) display(["deck","ace"]) # while there are aces on the top of the overturned # pile move them to the aces piles while getvalue(over[1]) = 1 do { s := getsuite(!over) push(ace[s],get(over)) display(["deck","ace"]) } return } }endprocedure run2ace(from) local fcard, a, s # set fcard to the low card of the run or fail if there are no # cards in the run fcard := (run[from][-1] | fail) # for every ace pile every a := !ace do { # if the top of the ace pile is one less than the from card # they are in the same suit and in sequence if a[-1] + 1 = fcard then { # move the card and update the display put(a,pull(run[from])) display([from,"ace"]) # if the from run is now empty and there are hidden # cards to expose if *run[from] = 0 & *hidden[from] > 0 then { # while there are aces on the top of the # hidden pile move them to the aces piles while getvalue(hidden[from][1]) = 1 do { s := getsuite(hidden[from][1]) push(ace[s],get(hidden[from])) display(["ace"]) } # put the top hidden card in the empty run # and display the hidden counts put(run[from],get(hidden[from])) display(["hide"]) } # update the from run display display([from]) return } }endprocedure run2run(from,dest,limitmove) local fcard, dcard, s # set fcard to the high card of the run or fail if there are no # cards in the run fcard := (run[from][1] | fail) # set dcard to the low card of the run or null if there are no # cards in the run dcard := (run[dest][-1] | &null) # avoid king thrashing in automatic mode (there's no point in # moving a king high run to an empty run if there are no hidden # cards under the king high run to be exposed) if amode > 0 & /dcard & getvalue(fcard) = 13 & *hidden[from] = 0 then fail # avoid wasted movement if the limit move parameter was passed # (there's no point in moving a pile if there are no hidden cards # under it unless you have a king in the deck) if amode > 0 & \limitmove & *hidden[from] = 0 then fail # check to see if the move is legal if chk2run(fcard,dcard) then { # add the from run to the dest run run[dest] |||:= run[from] # empty the from run run[from] := [] # display the updated runs display([from,dest]) # if there are hidden cards to expose if *hidden[from] > 0 then { # while there are aces on the top of the hidden # pile move them to the aces piles while getvalue(hidden[from][1]) = 1 do { s := getsuite(hidden[from][1]) push(ace[s],get(hidden[from])) display(["ace"]) } # put the top hidden card in the empty run and # display the hidden counts put(run[from],get(hidden[from])) display(["hide"]) } # update the from run display display([from]) return }endprocedure chk2run(fcard,dcard) # if dcard is null the from card must be a king or if ( /dcard & (getvalue(fcard) = 13 | fail) ) | # if the value of dcard is one more than fcard and ( getvalue(dcard) - 1 = getvalue(fcard) & # their colors are different they can be moved getcolor(dcard) ~= getcolor(fcard) ) then returnend# this procedure finishes a game where there are no hidden cards left and the# deck is emptyprocedure finish(cheat) movecursor(16,0) writes("\007I'll finish for you now\007") # finish moving the runs to the aces piles while movecard(!"7654321","a") movecursor(16,0) writes(CLREOL,"\007You WIN\007") if cheat > 0 then write("...but you cheated ",cheat," times!") else write("...and without cheating...congratulations!") exit(0)end# this procedure takes over and plays the game for youprocedure autopilot() local tseq, totdeck movecursor(16,0) writes("Going into automatic mode...") # set auto pilot mode amode := 1 # while there are cards that aren't in runs or the aces piles while (cardsleft()) > 0 do { # try to make any run to run plays that will uncover # hidden cards while movecard(!"7654321",!"1234567","hidden") # try for a move that will leave an empty spot if movecard(!"7654321",!"1234567") then next # if there's no overturned card thumb the deck if *over = 0 then thumb() # initialize the thumbed sequence set tseq := set() # try thumbing the deck for a play totdeck := *deck + *over every 1 to totdeck do { if movecard("d",!"1234567a") then break insert(tseq,over[1]) thumb() } # if we made a deck to somewhere move continue if totdeck > *deck + *over then next # try for a run to ace play if movecard(!"7654321","a") then next # if we got this far and couldn't play give up break } # position the cursor for the news movecursor(16,28) # if all the cards are in runs or the aces piles if cardsleft() = 0 then { writes("\007YEA...\007") # finish moving the runs to the aces piles while movecard(!"7654321","a") movecursor(16,34) write("I won!!!!!") exit(0) } else { writes("I couldn't win this time") # print the information needed to verify that the # program couldn't win movecursor(17,0) writes(*deck + *over," cards in deck") if *tseq > 0 then { write("...final thumbing sequence:") every writes(" ",face(!tseq)) } write() exit(1) }end# this procedure updates the displayprocedure display(parts) local r, a, h, c, part, l static long # a list with the length of each run initial { long := [1,1,1,1,1,1,1] } # if the argument list is empty or contains "all" update all parts # of the screen if /parts | !parts == "all" then { long := [1,1,1,1,1,1,1] parts := [ "label","hide","ace","deck", "1","2","3","4","5","6","7" ] } # for every part in the argument list every part := !parts do case part of { # display the run number, aces and deck labels "label" : { every r := 1 to 7 do { movecursor(1,7+(r-1)*5) writes(r) } movecursor(1,56) writes("ACES") movecursor(6,56) writes("DECK") } # display the hidden card counts "hide" : { every r := 1 to 7 do { movecursor(1,9+(r-1)*5) writes(0 < *hidden[r] | " ") } } # display the aces piles "ace" : { movecursor(3,49) every a := 1 to 4 do writes(face(ace[a][-1]) | "---"," ") } # display the deck and overturned piles "deck" : { movecursor(8,54) writes((*deck > 0 , " # ") | " "," ") writes(face(!over) | " "," ") } # display the runs piles "1" | "2" | "3" | "4" | "5" | "6" | "7" : { l := ((long[part] > *run[part]) | long[part]) h := ((long[part] < *run[part]) | long[part]) l <:= 1 every c := l to h do { movecursor(c+1,7+(part-1)*5) writes(face(run[part][c]) | " ") } long[part] := *run[part] } } returnend# this procedure t
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Fold
+++++ Continued from previous card +++++
humbs the deck 3 cards at a timeprocedure thumb() local s # if the deck is all thumbed if *deck = 0 then { # if there are no cards in the overturned pile either return if *over = 0 then return # turn the overturned pile back over while put(deck,pull(over)) } # turn over 3 cards or at least what's left every 1 to 3 do if *deck > 0 then push(over,get(deck)) display(["deck"]) # while there are aces on top of the overturned pile move them to # the aces pile while getvalue(over[1]) = 1 do { s := getsuite(over[1]) push(ace[s],get(over)) display(["deck","ace"]) } # if the overturned pile is empty again and there are still cards # in the deck thumb again (this will only happen if the top three # cards in the deck were aces...not likely but) if *over = 0 & *deck > 0 then thumb() returnend# this procedure shuffles a deck of cardsprocedure shuffle(cards) static fulldeck # the default shuffle is a full deck of cards initial { # set up a full deck of cards fulldeck := [] every put(fulldeck,1 to 52) # if seed isn't already set use the time to set it if /seed then seed := integer(&clock[1:3] || &clock[4:6] || &clock[7:0]) # seed the random number generator for the first time &random := seed } # if no cards were passed use the full deck /cards := fulldeck # copy the cards (shuffling is destructive) deck := copy(cards) # shuffle the deck every !deck :=: ?deck return deckendprocedure face(card) static cstr, # the list of card color escape sequences vstr, # the list of card value labels sstr # the list of card suite labels initial { cstr := [K] vstr := ["A",2,3,4,5,6,7,8,9,10,"J","Q","K"] if \VERSION == "IBM PC" then sstr := ["\003","\004","\005","\006"] else sstr := ["H","D","S","C"] } # return a string containing the correct color change escape sequence, # the value and suite labels right justified in 3 characters, # and the back to normal escape sequence return cstr[getcolor(card)] || right(vstr[getvalue(card)] || sstr[getsuite(card)],3) || NORMALend# a deck of cards is made up of 4 suites of 13 values; 1-13, 14-26, etc.procedure getvalue(card) return (card-1) % 13 + 1end# each suite of cards is made up of ace - king (1-13)procedure getsuite(card) return (card-1) / 13 + 1end# the first two suites are hearts and diamonds so all cards 1-26 are red# and all cards 27-52 are black.procedure getcolor(card) return (card-1) / 26 + 1end# this procedure counts cards that aren't in runs or the aces pilesprocedure cardsleft() local totleft # count the cards left in the deck and the overturned pile totleft := *deck + *over # add in the hidden cards every totleft +:= *!hidden return totleftend# this procedure implements a device dependent cursor positioning schemeprocedure movecursor(line,col) if \VERSION == "Atari ST" then writes("\eY",&ascii[33+line],&ascii[33+col]) else if \VERSION == "hp2621" then writes("\e&a",col,"c",line,"Y") else writes("\e[",line,";",col,"H")end# all invalid commands call this procedureprocedure whoops(cmd) local i, j movecursor(15,0) writes("\007Invalid Command: '",cmd,"'\007") # this delay loop can be diddled for different machines every i := 1 to 500 do j := i movecursor(15,0) writes("\007",CLREOL,"\007") returnend# display the help messageprocedure disphelp() static help initial { help := ["Commands: t or RETURN : thumb the deck 3 cards at a time"," m [d1-7] [1-7a] : move cards or runs"," a : turn on the auto pilot (in case you get stuck)"," s : shuffle the deck (cheat!)"," p [2-7] : put a hidden pile into the deck (cheat!)"," d : print the cards in the deck (cheat!)"," [2-7] : print the cards in a hidden pile (cheat!)"," h or ? : print this command summary"," r : print the rules of the game"," q : quit","","Moving: 1-7, 'd', or 'a' select the source and destination for a move. "," Valid moves are from a run to a run, from the deck to a run,"," from a run to an ace pile, and from the deck to an ace pile.","","Cheating: Commands that allow cheating are available but they will count"," against you in your next life!" ] } writes(CLEAR) every write(!help) writes("Hit RETURN") read() writes(CLEAR) display() returnend# display the rules messageprocedure disprules() static rules initial { rules := ["Object: The object of this game is to get all of the cards in each suit"," in order on the proper ace pile."," ","Rules: Cards are played on the ace piles in ascending order: A,2,...,K. "," All aces are automatically placed in the correct aces pile as"," they're found in the deck or in a pile of hidden cards. Once a"," card is placed in an ace pile it can't be removed.",""," Cards must be played in descending order: K,Q,..,2, on the seven"," runs which are initially dealt. They must always be played on a"," card of the opposite color. Runs must always be moved as a"," whole, unless you're moving the lowest card on a run to the"," correct ace pile.",""," Whenever a whole run is moved, the top hidden card is turned"," over, thus becoming the beginning of a new run. If there are no"," hidden cards left, a space is created which can only be filled by"," a king.",""," The rest of the deck is thumbed 3 cards at a time, until you spot"," a valid move. Whenever the bottom of the deck is reached, the"," cards are turned over and you can continue thumbing." ] } writes(CLEAR) every write(!rules) writes("Hit RETURN") read() writes(CLEAR) display() returnend :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldtablc.icn
############################################################################## Name: tablc.icn## Title: Tabulate characters in a file## Author: Ralph E. Griswold## Date: June 10, 1988############################################################################## # This program tabulates characters and lists each character and# the number of times it occurs. Characters are written using# Icon's escape conventions. Line termination characters and other# control characters are included in the tabulation.# # Options: The following options are available:# # -a Write the summary in alphabetical order of the charac-# ters. This is the default.# # -n Write the summary in numerical order of the counts.# # -u Write only the characters that occur just once.# ############################################################################## Links: options#############################################################################link optionsprocedure main(args) local ccount, unique, order, s, a, pair, rwidth, opts unique := 0 # switch to list unique usage only order := 3 # alphabetical ordering switch opts := options(args,"anu") if \opts["a"] then order := 3 if \opts["n"] then order := 4 if \opts["u"] then unique := 1 ccount := table(0) # table of characters while ccount[reads()] +:= 1 a := sort(ccount,order) if unique = 1 then { while s := get(a) do if get(a) = 1 then write(s) } else { rwidth := 0 every rwidth <:= *!a while s := get(a) do write(left(image(s),10),right(get(a),rwidth)) }end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldtablw.icn
############################################################################## Name: tablw.icn## Title: Tabulate words in a file## Author: Ralph E. Griswold## Date: December 27, 1989############################################################################## # This program tabulates words and lists number of times each# word occurs. A word is defined to be a string of consecutive# upper- and lowercase letters with at most one interior occurrence# of a dash or apostrophe.# # Options: The following options are available:# # -a Write the summary in alphabetical order of the words.# This is the default.# # -i Ignore case distinctions among letters; uppercase# letters are mapped into to corresponding lowercase# letters on input. The default is to maintain case dis-# tinctions.# # -n Write the summary in numerical order of the counts.# # -l n Tabulate only words longer than n characters. The# default is to tabulate all words.# # -u Write only the words that occur just once.# ############################################################################## Links: options, usage#############################################################################link options, usageglobal limit, icaseprocedure main(args) local wcount, unique, order, s, pair, lwidth, rwidth, max, opts, l, i limit := 0 # lower limit on usage to list unique := 0 # switch to list unique usage only order := 3 # alphabetical ordering switch opts := options(args,"ail+nu") if \opts["a"] then order := 3 if \opts["n"] then order := 4 if \opts["u"] then unique := 1 if \opts["i"] then icase := 1 l := \opts["l"] | 1 if l <= 0 then Usage("-l needs positive parameter") wcount := table(0) # table of words every wcount[words()] +:= 1 wcount := sort(wcount,order) if unique = 1 then { while s := get(wcount) do if get(wcount) = 1 then write(s) } else { max := 0 rwidth := 0 i := 1 while i < *wcount do { max <:= *wcount[i] rwidth <:= *wcount[i +:= 1] } lwidth := max + 3 while write(left(get(wcount),lwidth),right(get(wcount),rwidth)) }end# generate words#procedure words() local line, word while line := read() do { if \icase then line := map(line) line ? while tab(upto(&letters)) do { word := tab(many(&letters)) || ((tab(any('-\'')) || tab(many(&letters))) | "") if *word > limit then suspend word } }end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldtextcnt.icn
############################################################################## Name: textcnt.icn## Title: Tabulate properties of text file## Author: Ralph E. Griswold## Date: December 27, 1989############################################################################### This program tabulates the number of characters, "words", and# lines in standard input and gives the maxium and minimum line length.# ############################################################################procedure main() local chars, words, lines, name, infile, max, min, line chars := words := lines := 0 max := 0 min := 2 ^ 30 # larger than possible line length while line := read(infile) do { max <:= *line min >:= *line lines +:= 1 chars +:= *line + 1 line ? while tab(upto(&letters)) do { words +:= 1 tab(many(&letters)) } } if min = 2 ^ 30 then write("empty file") else { write("number of lines: ",right(lines,8)) write("number of words: ",right(words,8)) write("number of characters:",right(chars,8)) write() write("longest line: ",right(max,8)) write("shortest line: ",right(min,8)) }end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldtrim.icn
############################################################################## Name: trim.icn## Title: Trim lines in a file## Author: Ralph E. Griswold## Date: June 10, 1988############################################################################## # This program copies lines from standard input to standard out-# put, truncating the lines at n characters and removing any trail-# ing blanks. The default value for n is 80. For example,# # trim 70 <grade.txt >grade.fix# # copies grade.txt to grade.fix, with lines longer than 70 charac-# ters truncated to 70 characters and the trailing blanks removed# from all lines.# # The -f option causes all lines to be n characters long by# adding blanks to short lines; otherwise, short lines are left as# is.############################################################################### Links: options#############################################################################link optionsprocedure main(args) local n, pad, line, opts opts := options(args,"f") if \opts["f"] then pad := 1 else pad := 0 n := (0 <= integer(args[1])) | 80 while line := read() do { line := line[1+:n] line := trim(line) if pad = 1 then line := left(line,n) write(line) }end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldturing.icn
############################################################################## Name: turing.icn## Title: Simulate a Turing machine## Author: Gregg M. Townsend## Date: June 10, 1988############################################################################### This program simulates the operation of an n-state Turing machine,# tracing all actions. The machine starts in state 1 with an empty tape.## A description of the Turing machine is read from the file given as a# comand-line argument, or from standard input if none is specified.# Comment lines beginning with '#' are allowed, as are empty lines.## The program states must be numbered from 1 and must appear in order.# Each appears on a single line in this form:## sss. wdnnn wdnnn## sss is the state number in decimal. The wdnnn fields specify the# action to be taken on reading a 0 or 1 respectively:## w is the digit to write (0 or 1)# d is the direction to move (L/l/R/r, or H/h to halt)# nnn is the next state number (0 if halting)## Sample input file:## 1. 1r2 1l3# 2. 1l1 1r2# 3. 1l2 1h0## One line is written for each cycle giving the cycle number, current# state, and an image of that portion of the tape that has been visited# so far. The current position is indicated by reverse video (using# ANSI terminal escape sequences).## Input errors are reported to standard error output and inhibit# execution.## Bugs:## Transitions to nonexistent states are not detected.# Reverse video should be parameterizable or at least optional.# There is no way to limit the number of cycles.# Infinite loops are not detected. (Left as an excercise... :-)## Reference:## Scientific American, August 1984, pp. 19-23. A. K. Dewdney's# discussion of "busy beaver" turing machines in his "Computer# Recreations" column motivated this program. The sample above# is the three-state busy beaver.############################################################################### Links: options#############################################################################link optionsrecord action (wrt, mov, nxs)global machine, lns, lno, errsglobal cycle, tape, posn, state, videoprocedure main(args) local opts opts := options(args,"v") video := \opts["v"] rdmach(&input) # read machine description if errs > 0 then stop("[execution suppressed]") lns := **machine # initialize turing machine tape := "0" posn := 1 cycle := 0 state := 1 while state > 0 do { # execute dumptape() transit(machine[state][tape[posn]+1]) cycle +:= 1 } dumptape()end# dumptape - display current tape contents on screenprocedure dumptape() if cycle < 10 then writes(" ") writes(cycle,". [",right(state,lns),"] ",tape[1:posn]) if \video then write("\e[7m",tape[posn],"\e[m",tape[posn + 1:0]) else { write(tape[posn:0]) write(repl(" ",6 + *state + posn),"^") }end# transit (act) - transit to the next state peforming the given actionprocedure transit(act) tape[posn] := act.wrt if act.mov == "R" then { posn +:= 1 if posn > *tape then tape ||:= "0" } else if act.mov == "L" then { if posn = 1 then tape := "0" || tape else posn -:= 1 } state := act.nxs returnend# rdmach (f) - read machine description from the given fileprocedure rdmach(f) local nstates, line, a0, a1,n machine := list() nstates := 0 lno := 0 errs := 0 while line := trim(read(f),' \t') do { lno +:= 1 if *line > 0 & line[1] ~== "#" then line ? { tab(many(' \t')) n := tab(many(&digits)) | 0 if n ~= nstates + 1 then warn("sequence error") nstates := n tab(many('. \t')) a0 := tab(many('01LRHlrh23456789')) | "" tab(many(' \t')) a1 := tab(many('01LRHlrh23456789')) | "" pos(0) | (warn("syntax error") & next) put(machine,[mkact(a0),mkact(a1)]) } } lno := "<EOF>" if *machine = errs = 0 then warn("no machine!") returnend# mkact (a) - construct the action record specified by the given stringprocedure mkact(a) local w, m, n w := a[1] | "9" m := map(a[2],&lcase,&ucase) | "X" (any('01',w) & any('LRH',m)) | warn("syntax error") n := integer(a[3:0]) | (warn("bad nextstate"), 0) return action (w, m, n)end# warn (msg) - report an error in the machine descriptionprocedure warn(msg) write(&errout, "line ", lno, ": ", msg) errs +:= 1 returnend :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldunique.icn
############################################################################## Name: unique.icn## Title: Filter out identical adjacent lines## Author: Anthony Hewitt## Date: December 22, 1989############################################################################### Filters out identical adjacent lines in a file.#############################################################################procedure main() local s write(s := !&input) every write(s ~==:= !&input)end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldunpack.icn
############################################################################## Name: unpack.icn## Title: Unpackage files## Author: Ralph E. Griswold## Date: May 27, 1989############################################################################### This program unpackages files produced by pack.icn. See that program# for information about limitations.############################################################################### See also: pack.icn#############################################################################procedure main() local line, out while line := read() do { if line == "##########" then { close(\out) out := open(name := read(),"w") | stop("cannot open ",name) } else write(out,line) }end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldvnq.icn
############################################################################## Name: vnq.icn## Title: Display solutions to n-queens problem## Author: Stephen B. Wampler## Date: December 12, 1989############################################################################### Links: options#############################################################################link optionsglobal n, nthq, solution, goslow, showall, line, borderprocedure main(args)local i, opts opts := options(args, "sah") n := integer(get(args)) | 8 # default is 8 queens if \opts["s"] then goslow := "yes" if \opts["a"] then showall := "yes" if \opts["h"] then helpmesg() line := repl("| ", n) || "|" border := repl("----", n) || "-" clearscreen() movexy(1, 1) write() write(" ", border) every 1 to n do { write(" ", line) write(" ", border) } nthq := list(n+2) # need list of queen placement routines solution := list(n) # ... and a list of column solutions nthq[1] := &main # 1st queen is main routine. every i := 1 to n do # 2 to n+1 are real queen placement nthq[i+1] := create q(i) # routines, one per column. nthq[n+2] := create show() # n+2nd queen is display routine. write(n, "-Queens:") @nthq[2] # start by placing queen in first colm. movexy(1, 2 * n + 5)end# q(c) - place a queen in column c (this is c+1st routine).procedure q(c)local r static up, down, rows initial { up := list(2 * n -1, 0) down := list(2 * n -1, 0) rows := li } repeat { every (0 = rows[r := 1 to n] = up[n + r - c] = down[r + c -1] & rows[r] <- up[n + r - c] <- down[r + c -1] <- 1) do { solution[c] := r # record placement. if \showall then { movexy(4 * (r - 1) + 5, 2 * c + 1) writes("@") } @nthq[c + 2] # try to place next queen. if \showall then { movexy(4 * (r - 1) + 5, 2 * c + 1) writes(" ") } } @nthq[c] # tell last queen placer 'try again' }end# show the solution on a chess board.procedure show() local c static count, lastsol initial { count := 0 } repeat { if /showall & \lastsol then { every c := 1 to n do { movexy(4 * (lastsol[c] - 1) + 5, 2 * c + 1) writes(" ") } } movexy(1, 1) write("solution: ", right(count +:= 1, 10)) if /showall then { every c := 1 to n do { movexy(4 * (solution[c] - 1) + 5, 2 * c + 1) writes("Q") } lastsol := copy(solution) } if \goslow then { movexy(1, 2 * n + 4) writes("Press return to see next solution:") read() | { movexy(1, 2 * n + 5) stop("Aborted.") } movexy(1, 2 * n + 4) clearline() } @nthq[n+1] # tell last queen placer to try again }endprocedure helpmesg() write(&errout, "Usage: vnq [-s] [-a] [n]") write(&errout, " where -s means to stop after each solution, ") write(&errout, " -a means to show placement of every queen") write(&errout, " while trying to find a solution") write(&errout, " and n is the size of the board (defaults to 8)") stop()end# Move cursor to x, y#procedure movexy (x, y) writes("\^[[", y, ";", x, "H") returnend## Clear the text screen#procedure clearscreen() writes("\^[[2J") returnend## Clear the rest of the line#procedure clearline() writes("\^[[2K") returnend :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldzipsort.icn
############################################################################## Name: zipsort.icn## Title: Sort mailing labels by ZIP code## Author: Ralph E. Griswold## Date: June 10, 1988############################################################################## # This program sorts labels produced by labels in ascending# order of their postal zip codes.# # Option:## The option -d n sets the number of lines per label to n.# The default is 9. This value must agree with the value used to# format the labels.# # Zip Codes:## The zip code must be the last nonblank string at the# end of the label. It must consist of digits but may have an# embedded dash for extended zip codes. If a label does not end# with a legal zip code, it is placed after all labels with legal# zip codes. In such a case, an error messages also is written to# standard error output.# ############################################################################## Links: options## See also: labels.icn#############################################################################link optionsprocedure main(args) local t, a, label, zip, y, lsize, opts opts := options(args,"d+") lsize := (0 > integer(opts["d"])) | 9 t := table("") repeat { label := "" every 1 to lsize do label ||:= read() || "\n" | break break label ? { while tab(upto(' ')) do tab(many(' ')) zip := tab(upto('-') | 0) zip := integer(zip) | write(&errout,"*** illegal zipcode: ",label) } t[zip] ||:= label } a := sort(t,3) while get(a) do writes(get(a))end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs FoldREADME
The Icon Program Library Version 8The folder procs contains an MPW script, Translate, that translates all theprocedure files in procs. Do this first. Then set IPATH so that compilationof programs will be able to find the translated library procedures. Warning:IPATH must not contain blanks.An alternative to setting IPATH is to move the ucode files from procs intothe same folder as the programs (progs).The folder progs contains an MPW script, Compile, that compiles all theprograms in progs.The folder idol contains an object-oriented version of Icon written in Icon.See the documentation in that folder.tr90-7.doc is a text file for the document that summarizes the contents ofthe Icon program library. :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Foldtr90-7.doc
The Icon Program Library* Ralph E. Griswold TR 90-7b January 1, 1990; last revised March 8, 1990 Department of Computer Science The University of Arizona Tucson, Arizona 85721*This work was supported by the National Science Foundation underGrant CCR-8713690. The Icon Program Library1.__Introduction The Icon program library consists of Icon programs and pro-cedures as well as data. Icon Version 8 is required to run mostof the library [1,2]. In addition to the Icon program library proper, the librarydistribution contains an object-oriented version of Icon writtenin Icon. See [3] for instructions for unloading and using thisprogram. Section 6 briefly describes the contents of the library. Morecompete documentation is contained in comments in the program andprocedure files. You may wish to print these files to have docu-mentation handy. The material in the Icon program library was contributed byIcon users. It is in the public domain and may be copied freely.The Icon Project packages and distributes the library as a ser-vice to Icon programmers. The Icon project makes no warranties ofany kind as to the correctness of the material in the library orits suitability for any application. The responsibility for theuse of the library lies entirely with the user.2.__Unloading_the_Library The Icon program library consists of three parts: programs,collections of procedures, and data. Normally, these componentsshould be placed in separate directories named progs, procs, anddata. The method of unloading the distribution files varies fromsystem to system; system-specific instructions are includedseparately. The physical division of the library into progs, procs, anddata is motivated by logical and organizational considerations,not operational ones. Other names can be used and all thematerial can be placed in one directory, for example. This may benecessary on some systems.3.__Link_Search_Paths Many of the programs link procedures. For example, options isused by many programs for processing command-line options and islinked from ``ucode'' files obtained from translating - 1 -options.icn. Icon searches for ucode files first in the current directoryand then in directories specified by the IPATH environment vari-able. IPATH consists of a sequence of blank-separated pathnames. The search is in the order of the names. For example, on aUNIX system running csh, setenv IPATH "../procs /usr/icon/ilib"results in a search for file names in link declarations first inthe current directory, then in ../procs, and finally in/usr/icon/ilib. The method of setting IPATH varies from system to system.Since the current directory always is searched first, if ucodefiles are placed in the same directory as the program files,IPATH need not be set. See the next section.4.__Installing_the_Library Installing the Icon program library consists of two steps: (1)translating the procedure files to produce ucode files and (2)compiling the programs. Ucode files are produced by translating the procedure fileswith the -c option to icont, as in icont -c optionstranslates options.icn. The result is two ucode files namedoptions.u1 and options.u2. The .u1 files contains the procedure'scode and the .u2 file contains global information about the pro-cedure. It is these files that a link declaration such as link optionsneeds. A script for translating all the procedure files is providedwith the most distributions. Once the procedure files have beentranslated, the ucode files can be moved to any place that isaccessible from IPATH. The programs are compiled using icont without the -c option,as in icont dealwhich compiles deal.icn, a program that produces randomlyselected bridge hands. The result of compiling a program is an - 2 -``icode'' file whose name is system dependent. On some systems,the name is the same as the name of the program file with the.icn suffix removed (for example, deal). On other systems, theicode file has the suffix .icx in place of .icn (for example,deal.icx). On systems that support the direct execution of icode files(UNIX, for example), an icode file can be run just by enteringits name on the command line, as in deal On other systems (MS-DOS, for example), icode files must berun using the Icon executor, iconx, as in iconx deal(This also works on systems that support direct execution.) Notethat the suffix (if any) need not be mentioned. Many Icon programs take arguments and options from the commandline. Options are identified by dashes. For example, in deal -h 10the -h 10 instructs deal to produce 10 hands. Icode files can be moved to any location. Ucode files areneeded only during compilation. They need not be accessible whenicode files are run.5.__Usage_Notes It is important to read the documentation at the beginning ofprograms and procedures in the library. It includes informationabout special requirements, limitations, known bugs, and soforth. Some of the programs in the Icon program library are quitelarge and may require more memory than is available on some per-sonal computers. The library has evolved over a period of time. Some programswere written to run under earlier versions of Icon and do nottake advantage of all the features of Version 8. The procedure getopt, used to process command-line options inthe previous version of the library, has been replaced by theprocedure options, which is somewhat easier to use. If youpresently use getopt in other programs, you may wish to convertto options. - 3 -6.__Library_Contents As mentioned earlier, detailed documentation about programsand procedures is contained in their files. A brief catalog ofthe contents of the Icon program library follows.6.1__Programs animal: Play the familiar ``animal'' game. calc: Calculate Icon values. colm: Arrange data items in columns. concord: Produce a concordance. cross: Arrange words in intersecting crossword fashion. csgen: Generate sentences from a context-sensitive gram- mar. deal: Display randomly generated bridge hands. delam: Delaminate file into several files according to field specifications. delamc: Delaminate file into several files according to tabs. diffn: Show differences among several files. diffword: List the distinct words in a file. edscript: Produce script for the ed editor. empg: Produce program to measure Icon expressions. farb: Produce a ``Farberism''. fileprnt: Display representations of characters in a file. filter: Filter file. format: Format text. gcomp: Produce the complement of a UNIX file specifica- tion. grpsort: Sort groups of lines. hufftab: Compute state transitions for Huffman decoding. - 4 - ilnkxref: Produce link cross-reference of Icon program. ipp: Preprocess Icon programs. iprint: Print Icon program. ipsort: Sort procedures in Icon program. ipsplit: Split Icon program into separate procedure files. ipxref: Produce cross reference for Icon program. itab: Entab Icon program. iundecl: Find undeclared Icon identifiers. iwriter: Produce Icon expressions that write lines of file. krieg: Play game of kriegspiel. kross: Show all intersecting characters in two strings. kwic: Produce index of keywords in context. labels: Format mailing labels. lam: Laminate several files into one file. latexidx: Process LaTeX .idx file. linden: Generate strings in 0L-system. lisp: Interpret Lisp program. loadmap: Produce load map of UNIX object file. miu: Generate strings in MIU system. memsum: Summarize memory usage of Icon program. monkeys: Generate random text. pack: Package a group of files in a single file (see unpack). parens: Generate random parenthesis-balanced strings. parse: Parse infix expressions (see also parsex). parsex: Parse arithmetic expressions (see also parse). - 5 - press: Compress or uncompress file. proto: Compile all Icon syntactic forms. queens: Generate solutions to the n-queens problem (see also vnq). recgen: Produce recognizer for context-free language. roffcmds: List commands and macros in roff text. rsg: Generate random sentences from grammar. ruler: Write character ruler. shuffile: Shuffle lines in a file. solit: Play solitaire. tablc: Tabulate characters in a file. tablw: Tabulate words in a file. textcnt: Tabulate properties of a text file. trim: Trim lines in a file. turing: Simulate a Turing machine. unique: Filter out identical adjacent lines of a file. unpack: Unpackage a group of files (see pack). vnq: Display solutions to the n-queens problem interactively on an ANSI-standard terminal (see also queens). zipsort: Sort labels by ZIP code. 6.2__Procedures allof: Perform iterative conjunction. bincvt: Convert binary data. bold: Enbolden and underscore text. codeobj: Encode and decode Icon values as strings (see also object). collate: Collate and decollate strings. - 6 - colmize: Arrange data in columns. complex: Perform complex arithmetic. currency: Format in American currency. dif: Generate differences. escape: Interpret Icon literal escapes. filename: Parse file name. fullimag: Produce full image of Icon value (see also image and ximage). gcd: Compute greatest common divisor. gener: Generate various strings. hexcvt: Convert hexadecimal numbers. image: Produce image of Icon value. isort Sort with customization. largint: Perform arbitrary-precision integer arithmetic. lmap: Map list elements. mapbit: Map string into its bit representation. math: Perform mathematical computations. morse: Convert string to Morse code. ngrams: Tabulate n-grams in a text file. numbers: Convert numbers to various forms. object: Encode and decode Icon values as strings (see also codeobj). options: Process command-line options. patterns: Perform SNOBOL4-style pattern matching. patword: Produce letter pattern for a word. pdae: Perform programmer-defined argument evaluation. pdco: Perform programmer-defined control operations. - 7 - permute: Perform permutations, combinations, and other character rearrangements. phoname: Generate possible words from telephone numbers. printcol: Print columnar data. printf: Format in C printf style. radcon: Convert radix. rational: Perform rational arithmetic. segment: Segment string. seqimage: Produce string image of Icon result sequence. shquote: Quote words for shells. shuffle: Shuffle string or list. snapshot: Show state of Icon string scanning. strings: Perform operations on strings. structs: Perform operations on structures. tuple: Simulate n-tuples. usage: Provide interface operations. wildcard: Match UNIX wild-card patterns. wrap: Wrap text lines. ximage: Produce image of Icon value (see also fullimag and image).6.3__Data *.csg: Input to csgen. *.krs: Input to kross. *.lbl: Input to label. *.lin: Input to linden. *.rsg: Input to rsg. *.tur: Input to turing. - 8 - *.txt: Sample text. *.wrd: Word lists. farber.sen:Farberisms. palin.sen: Palindromic sentences.7.__Future_Library_Releases There are many contributions to the Icon program library thathave not yet been distributed. This material includes: + Programs that are operating-system specific. + Complex packages. + Programs that require specific data files. + Programs that need more documentation. + Recent arrivals.The Icon program library will be updated as this material is putinto a form suitable for distribution.8.__Note_to_Contributors Material for the Icon program library always is welcome. Itmust be prepared in the style exemplified by the material in thisrelease. Adequate documentation is essential; it must be in theformat used for present library - we do not have the resources torewrite or reformat contributed documentation. Test data alsomust be provided - at least enough so that we can determine thatthe contributed program material is basically functional. Incases where test data is impractical because of the nature of thecontribution, instructions for testing should be provided. Program material can be submitted by electronic mail at one ofthe addresses given in the next section or on magnetic media.Printed listings are not acceptable. Contributions to the Icon program library must be free of anyrestrictions. The decision to include contributed material in theIcon program library rests entirely with the Icon Project. TheIcon Project reserves the right to modify submissions to conformto library standards, to correct errors, and to make improve-ments. Contributors wil be consulted in the case of substantialchanges. - 9 -9.__Bugs If you find a bug in the Icon program library or can suggestan improvement, please let us know: Icon Project Department of Computer Science Gould-Simpson Building The University of Arizona Tucson, AZ 85721 U.S.A. (602) 621-4049 icon-project@cs.arizona.edu (Internet) ... {uunet, allegra, noao}!arizona!icon-project (uucp)Acknowledgements The following persons contributed material to this release ofthe Icon program library: Paul Abrahams Anthony Hewitt Gregg M. Townsend Robert J. Alexander Thomas R. Hicks Kenneth Walker Allan J. Anderson Tim Korb Stephen B. Wampler David S. Cargo William P. Malloy Kurt A. Welgehausen nary A. Coutant William H. Mitchell Robert C. Wieland Ward Cunningham Jerry Nowlin Cheyenne Wills Michael Glass Randal L. Schwartz George D. Yee Ralph E. Griswold David Slate David YostReferences1. R. E. Griswold and M. T. Griswold, The Icon Programming Language, Prentice-Hall, Inc., Englewood Cliffs, NJ, 1983.2. R. E. Griswold, Version 8 of Icon, The Univ. of Arizona Tech. Rep. 90-1, 1990.3. C. L. Jeffery, Programm
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Lib&Programs Fold
+++++ Continued from previous card +++++
ing in Idol - An Object Primer, The Univ. of Arizona Tech. Rep. 90-10, 1990. - 10 - :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Object OOPS Folder:idol:amiga.icn
## %W% %G%# OS-specific code for Amiga Idol#global lnkopt,cd,md,env,sysokprocedure mysystem(s) if \loud then write(s) return system(s)endprocedure filename(s) s[9:0] := "" return sendprocedure writesublink(s) writelink(env||"/"||s)endprocedure envpath(filename) return env||"/"||filenameend## Installation.# Uses hierarchical filesystem on some systems (see initialize)#procedure install(args) write("Installing idol environment in ",env) if env ~== "" then mysystem(md||env) fout := envopen("i_object.icn","w") write(fout,"record idol_object(__state,__methods)") close(fout) fout := &null cdicont(["i_object"])end procedure makeexe(args,i) exe := args[i] if icont(lnkopt||exe) = \sysok then { mysystem("delete "||exe||".icn") if \exec then { write("Executing:") exe := "iconx "||exe every i := exec+1 to *args do exe ||:= " "||args[i] mysystem(exe) } }end## system-dependent compilation of idolfile.icn# (in the idol subdirectory, if there is one)#procedure cdicont(idolfiles) if comp = -2 then return # -t --> don't call icont at all args := " -c" rms := "" every ifile := !idolfiles do args ||:= " " || ifile every ifile := !idolfiles do rms ||:= " " || ifile || ".icn" mysystem("cd idolcode.env") if icont(args) = \sysok then every ifile := !idolfiles do mysystem("delete "||ifile||".icn") mysystem("cd /")endprocedure sysinitialize() lnkopt := " -Sr500 -SF30 -Si1000 " cd := "cd " md := "makedir " env := "idolcode.env" sysok := 0end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Object OOPS Foldebi_test.iol
## Tests for the various builtins#procedure main() x := Table(1) write("\nTesting class ",x$class()) x$setElement("world","hello") write(x$getElement("world")) write(x$getElement("hello")) x := Deque() write("\nTesting class ",x$class()) x$push("hello") x$push("world") write("My deque is size ",$*x) every write("give me a ",$!x) write("A random element is ",$?x) write("getting ",x$get()," popping ",x$pop()) x := List(["Tucson", "Pima", 85721]) write("\nTesting class ",x$class()) every write("give me a ",$!x)end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Object OOPS Foldebuffer.iol
class buffer(public filename,text,index) # read a buffer in from a file method read() f := open(self.filename,"r") | fail self$erase() every put(self.text,!f) close(f) return end # write a buffer out to a file method write() f := open(self.filename,"w") | fail every write(f,!self.text) close(f) end # insert a line at the current index method insert(s) if self.index = 1 then { push(self.text,s) } else if self.index > *self.text then { put(self.text,s) } else { self.text := self.text[1:self.index]|||[s]|||self.text[self.index:0] } self.index +:= 1 return end # delete a line at the current index method delete() if self.index > *self.text then fail rv := self.text[self.index] if self.index=1 then pull(self.text) else if self.index = *self.text then pop(self.text) else self.text := self.text[1:self.index]|||self.text[self.index+1:0] return rv end # move the current index to an arbitrary line method goto(l) if (0 <= l) & (l <= self.index+1) then return self.index := l end # return the current line and advance the current index method forward() if self.index > *self.text then fail rv := self.text[self.index] self.index +:= 1 return rv end # place the buffer's text into a contiguously allocated list method linearize() tmp := list(*self.text) every i := 1 to *tmp do tmp[i] := self.text[i] self.text := tmp end method erase() self.text := [ ] self.index := 1 end initially if \ (self.filename) then { if not self$read() then self$erase() } else { self.filename := "*scratch*" self.erase() } endclass buftable : buffer() method read() self$buffer.read() tmp := table() every line := !self.text do line ? { tmp[tab(many(&ucase++&lcase))] := line | fail } self.text := tmp return end method lookup(s) return self.text[s] endendclass bibliography : buftable()endclass spellChecker : buftable(parentSpellChecker) method spell(s) return \ (self.text[s]) | (\ (self.parentSpellChecker))$spell(s) endendclass dictentry(word,pos,etymology,definition) method decode(s) # decode a dictionary entry into its components s ? { self.word := tab(upto(';')) move(1) self.pos := tab(upto(';')) move(1) self.etymology := tab(upto(';')) move(1) self.definition := tab(0) } end method encode() # encode a dictionary entry into a string return self.word||";"||self.pos||";"||self.etymology||";"||self.definition endinitially if /self.pos then { # constructor was called with a single string argument self$decode(self.word) }endclass dictionary : buftable() method read() self$buffer.read() tmp := table() every line := !self.text do line ? { tmp[tab(many(&ucase++&lcase))] := dictentry(line) | fail } self.text := tmp end method write() f := open(b.filename,"w") | fail every write(f,(!self.text)$encode()) close(f) endend :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Object OOPS Foldebuftest.iol
# buffer classes' testsprocedure main(args) if *args=0 then stop("usage: buftest cp file1 file2") every i := 1 to *args do { case args[i] of { "cp": { cp(args) } } }endprocedure cp(args) b1 := buffer(args[2]) b2 := buffer(args[3]) b2$erase() while s:=b1$forward() do b2$insert(s) b2$write()end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Object OOPS Foldebuiltins.iol
# %W% %G%## Builtin Icon objects, roughly corresponding to the language builtins.## Taxonomy of builtin types:## __Object___# _-' `-_# _-' `-_# Collection Atom_# / | \ _' `-.# Stack Queue Vector _-' Number# \ / / | \ _-' / \ # Deque / | \ _' Integer Real# \ / | \ /# List Table String## ## this is the Smalltalk-style ideal root of an inheritance hierarchy.# add your favorite methods here.#class Object() method class() return image(self)[8:find("_",image(self))] endendclass Collection : Object (theCollection) method size() return *self.theCollection end method foreach() suspend !self.theCollection end method random() return ?self.theCollection endendclass Vector : Collection() method getElement(i) return self.theCollection[i] end method setElement(i,v) return self.theCollection[i] := v endendclass Table : Vector(initialvalue,theCollection)initially self.theCollection := table(self.initialvalue)end## The field theCollection is explicitly named so that subclasses of Stack# and Queue use these automatic initializations. The / operator is used# to reduce the number of throw-away list allocations for subclasses which# >don't< inherit theCollection from Stack or Queue (e.g. class List).# It also allows initialization by constructor. If one wanted to# guarantee that all Stacks start out empty but still allow class List# to be explicitly intitialized, one could remove the / here, and name# theCollection in class List, causing its initially section to override# the superclass with respect to the field theCollection. I choose here# to maximize code sharing rather than protecting my Stack class.## When allowing initialization by constructor one might consider# checking the type of the input to guarantee it conforms to the# type expected by the class.#class Stack : Collection(theCollection) method push(value) push(self.theCollection,value) end method pop() return pop(self.theCollection) endinitially /self.theCollection := []endclass Queue : Collection(theCollection) method get() return get(self.theCollection) end method put(value) put(self.theCollection,value) endinitially /self.theCollection := []endclass Deque : Queue : Stack()end## List inherits Queue's theCollection initialization, because Queue is the# first class on List's (transitively closed) superclass list to name# theCollection explicitly#class List : Deque : Vector() method concat(l) return List(self.theCollection ||| l) endendclass Atom : Object(public val) method asString() return string(self.val) end method asInteger() return integer(self.val) end method asReal() return real(self.val) endendclass Number : Atom () method plus(n) return self.val + n$val() end method minus(n) return self.val - n$val() end method times(n) return self.val * n$val() end method divide(n) return self.val / n$val() endendclass Integer : Number()initially if not (self.val := integer(self.val)) then stop("can't make Integer from ",image(self.val))endclass Real : Number()initially if not (self.val := real(self.val)) then stop("can't make Real from ",image(self.val))endclass String : Vector : Atom() method concat(s) return self.theCollection || s endend :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Object OOPS Foldefraction.iol
class fraction(n,d) method n() return self.n end method d() return self.d end method times(f) return fraction(self.n * f$n(), self.d * f$d()) end method asString() return self.n||"/"||self.d end method asReal() return real(self.n) / self.d endinitially if self.d=0 then stop("fraction: denominator=0")end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Object OOPS Foldeidol.1
.TH IDOL 1 "26 February 1990".UC 4.SH NAMEidol \- Icon-Derived Object Language.SH SYNOPSIS.B idol.B \-install.br.B idol[.B option...]mainfile otherfiles[.B \-xarguments].SH DESCRIPTION.PP.I Idolis an object-oriented preprocessor for Version 7.5+ Icon.It is a front-end for.I icont(1); typically one invokes idol ona source file (extension .iol) which is translated into anIcon source file (extension .icn) which is translated into afile suitable for interpretation by the Icon interpreter.Each directory containing Idol source files should be initializedby .B idol.B \-installprior to translating any user sources.Producing an executable is skipped when the first file on thelist contains only classes..PPThe.B \-coption suppresses the linking phase normally done by.I Icont..PPThe.B \-toption suppresses.B alltranslation by.I Icont;it is useful on systems for which Icon does not support the.br.B system\(\)function..PPThe.B \-soption suppresses removal of.B \.icnfiles after translation by.I Icont;normally they are deleted after a successful translation..PPThe.B \-quietoption suppresses most Idol-specific console messages..PPThe.B \-installoption installs the Idol.B environment.brin the current directory..PPThe.B \-strictoption causes.I Idolto generate code which is paranoid about ensuring encapsulation..PPThe.B \-versionoption causes.I Idolto print out its version and date of creation, and then exit..PPThe second and following files on the command line may includeextensions.B \.icn,.B \.u1, and.B \.cl\.The first two Idol treats asIcon source code which should be translated and linked into theresulting executable. Files with extension.B \.clare treated as class names which are linked into the resulting executable..PP.SH AUTHOR.PPClinton Jeffery, cjeffery@cs.arizona.edu.PP.SH FILES.PP.nfidol The Idol translator itself..brprog.iol Idol source files.brprog.icn Icon code (non-classes) from prog.iol.bridolcode.env/i_object.* Icon code for the Idol object type.bridolcode.env/classname.icn Icon files generated for each class.bridolcode.env/classname.u[12] Translated class files.bridolcode.env/classname Class specification/interface.fiALSO.PP.br"Programming in Idol: An Object Primer".br(U of Arizona Dept of CS Technical Report #90-10).brserves as a user's guide and reference manual for Idol :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Object OOPS Foldeidol.bat
Programming in Idol: An Object Primer Clinton L. Jeffery March 14, 1990Idol is an object-oriented extension and environment for theIcon programming language. This document describes Idol in two parts.The first part presents Idol's object-oriented programming conceptsas an integral tool with which a programmer maps a good programdesign into a good implementation. As such, it serves asof "user's guide" for Idol's extensions to Icon. Idol'sobject-oriented programming facilities are viewed within thebroader framework of structured programming and modular designin general. Idol's precise syntax and semantics are detailed in thesecond part, "An Icon-Derived Object Language", which serves as areference manual. Object-Oriented Programming After a FashionObject-oriented programming means different things to different people.In Idol, object-oriented programming centers around encapsulation,inheritance, and polymorphism. These key ideas are shared by mostobject-oriented languages as well as many languages that are notconsidered object-oriented. This paper introduces these ideas andillustrates their use in actual code. Idol is relevant in thisdiscussion because programming concepts are more than mentalexercises; they are mathematical notations by which programmers sharetheir knowledge.Object-oriented programming can be done in Smalltalk, C++, orassembler language for that matter, but this does not mean theseprogramming notations are equally desirable. Assembler languagesare not portable. For most programmers, Smalltalk uses an aliennotation; Smalltalk programs also share the flaw that they do notwork well in environments such as UNIX and DOS that consist ofinteracting programs written in many languages. C++ has neither ofthese flaws, but the same low-level machine-oriented characterthat makes it efficient also makes C++ less than ideal as analgorithmic notation usable by nonexperts.Idol owes most of its desirable traits to its foundation, the Iconprogramming language, developed at the University of Arizona[Griswold83]. In fact, Idol presents objects simply as a toolto aid in the writing of Icon programs. Idol integrates a concise,robust notation for object-oriented programming into a languageconsiderably more advanced than C or Pascal. Icon already uses apowerful notation for expressing a general class of algorithms. Thepurpose of Idol is to enhance that notation, not to get in the way. Key ConceptsThis section describes the general concepts that Idol suppliesto authors of large Icon programs. The following section providesprogramming examples that employ these tools. The reader isencouraged to refer back to this section when clarification inthe examples section is needed.The single overriding reason for object-oriented programmingis the large program. Simple programs can be easily written inany notation. Somewhere between the 1,000-line mark and the10,000-line mark most programmers can no longer keep track of theirentire program at once. By using a very high-level programming language,less lines of code are required; a programmer can write perhaps tentimes as large a program and still be able to keep track of things.As programmers are required to write larger and larger programs,the benefit provided by very-high level languages does not keep upwith program complexity. This obstacle has been labelled the"software crisis", and object-oriented programming addresses thiscrisis. In short, the goals of object-oriented programming are toreduce the amount of coding required to write very large programs andto allow code to be understood independently of the context of thesurrounding program. The techniques employed to achieve these goalsare discussed below. EncapsulationThe primary concept advocated by object-oriented programming is theprinciple of encapsulation. Encapsulation is the isolation, in thesource code that a programmer writes, of a data representation and the codethat manipulates the data representation. In some sense, encapsulationis an assertion that no other routines in the program have "side-effects"with respect to the data structure in question. It is easier to reasonabout encapsulated data because all of the source code that could affectthat data is immediately present with its definition.Encapsulation does for data structures what the procedure does foralgorithms: it draws a line of demarcation in the program text, theoutside of which is (or can be, or ought to be) irrelevant to the inside.We call an encapsulated data structure an object. Just as a set ofnamed variables called parameters comprise the only interface between aprocedure and the code that uses it, a set of named procedures calledmethods comprise the only interface between an object and the code thatuses it.This textual definition of encapsulation as a property of programsource code accounts for the fact that good programmers can writeencapsulated data structures in any language. The problem is notcapability, but verification. In order to verify encapsulation someobject-oriented languages, like C++, define an elaborate mechanism bywhich a programmer can govern the visibility of each data structure.Like Smalltalk, Idol instead attempts to simplify verification bypreventing violations of encapsulation entirely. InheritanceIn large programs, the same or nearly the same data structures areused over and over again for a myriad of different purposes. Similarly,variations on the same algorithms are employed by structure afterstructure. In order to minimize redundancy, techniques are needed tosupport code sharing for both data structures and algorithms.Code is shared by related data structures by a programming conceptcalled inheritance.The basic premise of inheritance is simple: if I need to write codefor a new data structure which is similar to one that's alreadywritten, I can specify the new structure by giving the differencesbetween it and the old structure, instead of copying and then modifyingthe old structure's code. Obviously there are times when theinheritance mechanism is not useful: if the two data structures aremore different than they are similar, or if they are simple enoughthat inheritance would only confuse things, for example.Inheritance addresses a variety of common programming problems foundat different conceptual levels. The most obvious software engineeringproblem it solves might be termed enhancement. During thedevelopment of a program, its data structures may require extensionvia new state variables or new operations or both; inheritance isespecially useful when both the original structure and the extensionare used by the application. Inheritance also supportssimplification, or the reduction of a data structure's state variablesor operations. Simplification is analogous to argument culling afterthe fashion of the lambda calculus; it captures a logical relationbetween structures rather than a common situation in softwaredevelopment. In general, inheritance may be used in source code todescribe any sort of relational hyponymy, or special-casing; in Idolthe collection of all inheritance relations defines a directed (notnecessarily acyclic) graph. PolymorphismFrom the perspective of the writer of related data structures,inheritance provides a convenient method for code sharing, butwhat about the code that uses objects? Since objects areencapsulated, that code is not dependent upon the internals ofthe object at all, and it makes no difference to the client codewhether the object in questions belongs to the original class or theinheriting class.In fact, we can make a stronger statement. Due to encapsulation,two different executions of some code that uses objects to implementa particular algorithm may operate on different objects that arenot related by inheritance at all. Such code may effectivelybe shared by any objects that happen to implement the operationsthat the code invokes. This facility is called polymorphism, andsuch algorithms are called generic. This feature is found innon-object oriented languages; in object-oriented languages it isa natural extension of encapsulation. Object ProgrammingThe concepts introduced above are used in many programming languagesin one form or another. The following text presents these conceptsin the context of actual Idol code. This serves a dual purpose:it should clarify the object model adopted by Idol as well asprovide an initial impression of these concepts' utility in coding.In order to motivate the constructs provided by Idol, our examplebegins by contrasting conventional Icon code with Idol code whichimplements the same behavior. The semantics of the Idol code givenhere is defined by the Idol reference manual, included later in thisdocument in the section entitled, "An Icon-Derived Object Language". Before ObjectsIn order to place Idol objects in their proper context, the firstexample is taken from from regular Icon. Suppose I am writing sometext-processing application such as a text editor. Such applicationsneed to be able to process Icon structures holding the contents ofvarious text files. I might begin with a simple structure like thefollowing:record buffer(filename,text,index)where filename is a string, text is a list of stringscorresponding to lines in the file, and index is a marker forthe current line at which the buffer is being processed. Icon recorddeclarations are global; in principle, if the above declaration needsto be changed, the entire program must be rechecked. A devotee ofstructured programming would no doubt write Icon procedures to readthe buffer in from a file, write it out to a file, examine, insertand delete individual lines, etc. These procedures, along with therecord declaration given above, can be kept in a separate source file(buffer.icn) and understood independently of the program(s) inwhich they are used. Here is one such procedure:# read a buffer in from a fileprocedure read_buffer(b) f := open(b.filename) | fail b.text := [ ] b.position := 1 every put(b.text,!f) close(f) return bendThere is nothing wrong with this example; in fact its similarity to theobject-oriented example that follows demonstrates that a good, modulardesign is the primary effect encouraged by object-oriented programming.Using a separate source file to contain a record type and thoseprocedures which operate on that type allows an Icon programmer tomaintain a voluntary encapsulation of that type. After ObjectsHere is the same buffer abstraction coded in Idol. This examplelays the groundwork for some more substantial techniques to follow.class buffer(public filename,text,index) # read a buffer in from a file method read() f := open(self.filename) | fail self$erase() every put(self.text,!f) close(f) return end # write a buffer out to a file method write() f := open(self.filename,"w") | fail every write(f,!self.text) close(f) end # insert a line at the current index method insert(s) if self.index = 1 then { push(self.text,s) } else if self.index > *self.text then { put(self.text,s) } else { self.text := self.text[1:self.index]|||[s]|||self.text[self.index:0] } self.index +:= 1 return end # delete a line at the current index method delete() if self.index > *self.text then fail rv := self.text[self.index] if self.index=1 then pull(self.text) else if self.index = *self.text then pop(self.text) else self.text := self.text[1:self.index]|||self.text[self.index+1:0] return rv end # move the current index to an arbitrary line method goto(l) if (0 <= l) & (l <= self.index+1) then return self.index := l end # return the current line and advance the current index method forward() if self.index > *self.text then fail rv := self.text[self.index] self.index +:= 1 return rv end method erase() self.text := [ ] self.index := 1 endinitially if \ (self.filename) then { if not self$read() then self$erase() } else { self.filename := "*scratch*" self$erase() }endThis first example is not complex enough to illustrate the fullobject-oriented style, but its a start. Pertaining to thegeneral concepts introduced above, we can make the followinginitial observations:Polymorphism. A separate name space for each class's methodsmakes for shorter names. The same method name can be used in eachclass that implements a given operation. This notation is moreconcise than is possible with standard Icon procedures. Moreimportantly it allows algorithms to operate correctly upon objects ofany class which implements the operations required by the algorithm.Constructors. A section of code is executed automatically whenthe constructor is called, allowing initialization of fields to valuesother than &null. Of course, this could be simulated in Iconby writing a procedure that had the same effect; the value of theconstructor is that it is automatic; the programmer is freed from theresponsibility of remembering to call this code everywhere objects arecreated in the client program(s). This tighter coupling of memoryallocation and its corresponding initialization removes one moresource of program errors, especially on multiprogrammer projects.These two observations share a common theme: the net effect is thateach piece of data is made responsible for its own behavior in thesystem. Although this first example dealt with simple line-orientedtext files, the same methodology applies to more abstract entitiessuch as the components of a compiler's grammar (This exampleis taken from the Idol translator itself, which provides anotherextended example of polymorphism and inheritance.).Idol's code sharing facilities are illustrated if we extend the aboveexample. Suppose the application is more than just a text editor---it includes word-associative databases such as a dictionary,bibliography, spell-checker, thesaurus, etc. These various databasescan be represented internally using Icon tables. The table entriesfor the databases vary, but the databases all use string keywordlookup. As external data, the databases can be stored in text files,one entry per line, with the keyword at the beginning. The formatof the rest of the line varies from database to database.Although all these types of data are different, the code used toread the data files can be shared, as well as the initial constructionof the tables. In fact, since we are storing our data one entry perline in text files, we can use the code already written for buffersto do the file i/o itself.class buftable : buffer() method read() self$buffer.read() tmp := table() every line := !self.text do line ? { tmp[tab(many(&letters))] := line | fail } self.text := tmp return end method lookup(s) return self.text[s] endendThis concise example shows how little must be written to achievedata structures with vastly different behavioral characteristics,by building on code that is already written. The superclassread() operation is one important step of the subclassread() operation; this technique is common enough to have aname: it is called method combination in the literature. Itallows one to view the subclass as a transformation of thesuperclass. The buftable class is given in its
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Object OOPS Folde
+++++ Continued from previous card +++++
entirety, butour code sharing example is not complete: what about the datastructures required to support the databases themselves? They are allvariants of the buftable class, and a set of possibleimplementations is given below. Note that the formats presented aredesigned to illustrate code sharing; clearly, an actual applicationmight make different choices. BibliographiesBibliographies might consist of a keyword followed by an uninterpretedstring of information. This imposes no additional structure on thedata beyond that imposed by the buftable class. An examplekeyword would be Jeffery90.class bibliography : buftable()end Spell-checkersThe database for a spell-checker is presumably just a list of words,one per line; the minimal structure required by the buftableclass given above. Some classes exist to introduce new terminologyrather than define a new data structure. In this case we introducea lookup operation which may fail, for use in tests. In addition,since ma-checking systems allow user definable dictionariesin addition to their central database, we allow spellCheckerobjects to chain together for the purpose of looking up words.class spellChecker : buftable(parentSpellChecker) method spell(s) return \ (self.text[s]) | (\ (self.parentSpellChecker))$spell(s) endend DictionariesDictionaries are slightly more involved. Each entry might consist of apart of speech, an etymology, and an arbitrary string of uninterpretedtext comprising a definition for that entry, separated by semicolons.Since each such entry is itself a structure, a sensible decompositionof the dictionary structure consists of two classes: one that managesthe table and external file i/o, and one that handles the manipulationof dictionary entries, including their decoding and encoding asstrings.class dictionaryentry(word,pos,etymology,definition) method decode(s) # decode a dictionary entry into its components s ? { self.word := tab(upto(';')) move(1) self.pos := tab(upto(';')) move(1) self.etymology := tab(upto(';')) move(1) self.definition := tab(0) } end method encode() # encode a dictionary entry into a string return self.word||";"||self.pos||";"||self.etymology||";"||self.definition endinitially if /self.pos then { # constructor was called with a single string argument self$decode(self.word) }endclass dictionary : buftable() method read() self$buffer.read() tmp := table() every line := !self.text do line ? { tmp[tab(many(&letters))] := dictionaryentry(line) | fail } self.text := tmp end method write() f := open(b.filename,"w") | fail every write(f,(!self.text)$encode()) close(f) endend ThesauriAlthough an oversimplification, one might conceive of a thesauri as alist of entries, each of which consists of a comma-separated list ofsynonyms followed by a comma-separated list of antonyms, with asemicolon separating the two lists. Since the code for such astructure is nearly identical to that given for dictionaries above,we omit it here (but one might reasonably capture a generalizationregarding entries organized as fields separated by semicolons). Objects and Icon Programming TechniquesIn examining any addition to a language as large as Icon, asignificant question is how that addition relates to the rest of thelanguage. In particular, how does object-oriented programming fit intothe suite of advanced techniques used regularly by Icon programmers?Previous sections of this document expound objects as anorganizational tool, analogous but more effective than the use ofseparate compilation to achieve program modularity. Object-orientedprogramming goes considerably beyond that viewpoint.Whether viewed dynamically or statically, the primary effect achievedby object-oriented programming is the subdivision of program data inparallel with the code. Icon already provides a variety of tools thatachieve related effects:Local and Static Variables in Icon procedures are the simplestimaginable parallel association of data and code. We do not discussthem further, although they are by no means insignificant.Records allow a simple form of user-defined types. They providea useful abstraction, but keeping records associated with the rightpieces of code is still the job of the programmer.String Scanning creates scanning environments. These are veryuseful, but not very general: not all problems can be cast asstring operations.Co-expressions save a program state for later evaluation. Thispowerful facility has a sweeping range of uses, but unfortunately itis a relatively expensive mechanism that is frequently misused toachieve a simple effect.Objects and classes, if they are successful, allow a significantgeneralization of the techniques developed around the abovelanguage mechanisms. Objects do not replace these languagemechanisms, but in many cases presented below they provide anattractive alternative means of achieving similar effects. Objects and recordsObjects are simply records whose field accesses are voluntarilylimited to a certain set of procedures. Objects and scanning environmentsString scanning in Icon is another example of associating a piece ofdata with the code that operates on it. In an Icon scanningexpression of the form e1 ? e2, the result of evaluatinge1 is used implicitly in e2 via a variety of scanningfunctions. In effect, the scanning operation defines a scope in whichstate variables &subject and &pos are redefined.[Walker86] proposes an extension to Icon allowingprogrammer-defined scanning environments. The extension involves a newrecord data type augmented by sections of code to be executed uponentry, resumption, and exit of the scanning environment. The Iconscanning operator was modified to take advantage of the new facilitywhen its first argument was of the new environment data type.While objects cannot emulate Icon string scanning syntactically, theygeneralize the concept of the programmer-defined scanning environment.Classes in the Idol standard library include a wide variety ofscanning environments in addition to conventional strings. Thevariation is not limited to the type of data scanned; it also includesthe form and function of the scanning operations. The form ofscanning operations available are defined by the state variables theyaccess; in the case of Icon's built-in string scanning, a singlestring and a single integer index into that string.There is no reason that a scanning environment cannot maintain a morecomplex state, such as an input string, an output string, and a pairof indices and directions for each string. Rather than illustratethe use of objects to construct scanning environments with such anabstract model, a concrete example is presented below. List scanningList scanning is a straightforward adaptation of string scanning tothe list data type. It consists of a library class namedListScan that implements the basic scanning operations, andvarious user classes that include the scanning expressions. Thisformat is required due to Idol's inability to redefine the semanticsof the ? operator or to emulate its syntax in any reasonableway. The state maintained during a list scan consists ofSubject and Pos, analogous to &subject and&pos, respectively.ListScan defines analogies to the basic scanning functions ofIcon, e.g. tab, upto, many, any, etc. Thesefunctions are used in methods of a ListScan client class, whichin turn defines itself as a subclass of ListScan. A client such as:class PreNum : ListScan() method scan() mypos := self.Pos suspend self$tab(self$upto(numeric)) self.Pos := mypos endendmay be used in an expression such as(PreNum(["Tucson", "Pima", 15.0, [ ], "3"]))$scan()producing the result ["Tucson", "Pima"]. The conventional Iconstring scanning analogy would be: "abc123" ? tab(upto(&digits)),which produces the result "abc". Note that ListScanmethods frequently take list-element predicates as arguments wheretheir string scanning counterparts take csets. In the above example,the predicate numeric supplied to upto is an Iconfunction, but predicates may also be arbitrary user-defined procedures.The part of the Idol library ListScan class required tounderstand the previous example is presented below. This code isrepresentative of user-defined scanning classes allowing patternmatching over arbitrary data structures in Idol. Althoughuser-defined scanning is more general than Icon's built-in scanningfacilities, the scanning methods given below are alwaysactivated in the context of a specific environment. Icon stringscanning functions can be supplied an explicit environment usingadditional arguments to the function.class ListScan(Subject,Pos) method tab(i) if i<0 then i := *self.Subject+1-i if i<0 | i>*self.Subject+1 then fail origPos := self.Pos self.Pos := i suspend self.Subject[origPos:i] self.Pos := origPos end method upto(predicate) origPos := self.Pos every i := self.Pos to *(self.Subject) do { if predicate(self.Subject[i]) then suspend i } self.Pos := origPos endinitially /(self.Subject) := [ ] /(self.Pos) := 1end Objects and co-expressionsObjects cannot come close to providing the power of co-expressions,but they do provide a more efficient means of achieving well-knowncomputations such as parallel expression evaluation that have beenpromoted as uses for co-expressions. In particular, a co-expressionis able to capture implicitly the state of a generator for laterevaluation; the programmer is saved the trouble of explicitly codingwhat can be internally and automatically performed by Icon'sexpression mechanism. While objects cannot capture a generator stateimplicitly, the use of library objects mitigates the cost ofexplicitly encoding the computation to be performed, as analternative to the use of co-expressions. The use of objects also isa significant alternative for implementations of Icon in whichco-expressions are not available or memory is limited. Parallel evaluationIn [Griswold87], co-expressions are used to obtain the resultsfrom several generators in parallel:decimal := create(0 to 255)hex := create(!"0123456789ABCDEF" || !"0123456789ABCDEF")octal := create((0 to 3) || (0 to 7) || (0 to 7))character := create(image(!&cset))while write(right(@decimal,3)," ",@hex," ",@octal," ",@character)For the Idol programmer, one alternative to using co-expressions wouldbe to link in the following code from the Idol standard library:procedure sequence(bounds[ ]) return Sequence(bounds)endclass Sequence(bounds,indices) method max(i) elem := self.bounds[i] return (type(elem)== "integer",elem) | *elem-1 end method elem(i) elem := self.bounds[i] return (type(elem)== "integer",self.indices[i]) | elem[self.indices[i]+1] end method activate() top := *(self.indices) if self.indices[1] > self$max(1) then fail s := "" every i := 1 to top do { s ||:= self$elem(i) } repeat { self.indices[top] +:= 1 if top=1 | (self.indices[top] <= self$max(top)) then break self.indices[top] := 0 top -:= 1 } return s endinitially / (self.indices) := list(*self.bounds,0)endOn the one hand, the above library code is neither terse nor generalcompared with co-expressions. This class does, however, allow theparallel evaluation problem described previously to be coded as:decimal := sequence(255)hex := sequence("0123456789ABCDEF","0123456789ABCDEF")octal := sequence(3,7,7)character := sequence(string(&cset))while write(right($@decimal,3)," ",$@hex," ",$@octal," ",image($@character))$@ is the unary Idol meta-operator that invokes theactivate() operation. Since the sequence class is alreadywritten and available, its use is an attractive alternative toco-expressions in many settings. For example, a general class oflabel generators (another use of co-expressions cited in[Griswold87]) is defined by the following library class:class labelgen : Sequence(prefix,postfix) method activate() return self.prefix||self$Sequence.activate()||self.postfix endinitially /(self.prefix) := "" /(self.postfix) := "" /(self.bounds) := [50000]endAfter creation of a label generator object (e.g.label := labelgen("L",":")), each resulting label is obtainedvia $@label. The sequence defined by this example is L0: L1: ... L50000: ConclusionIdol presents object programming as a collection of tools to reducethe complexity of large Icon programs. These tools are encapsulation,inheritance, and polymorphism. Since a primary goal of Idol is topromote code sharing and reuse, a variety of specific programmingproblems have elegant solutions available in the Idol class library. An Icon-Derived Object LanguageThis section serves as the language reference manual for Idol. Idolis a preprocessor for Icon which implements a means of associating apiece of data with the procedures which manipulate it. The primarybenefits to the programmer are thus organizational. The Iconprogrammer may view Idol as providing an augmented record type inwhich field accesses are made not directly on the records' fields, butrather through a set of procedures associated with the type. ClassesSince Idol implements ideas found commonly in object-orientedprogramming languages, its terminology is taken from that domain. Theaugmented record type is called a "class". The syntax of a class is:class foo(field1,field2,field3,...) # procedures to access # class foo objects[code to initialize class foo objects]endIn order to emphasize the difference between ordinary Icon proceduresand the procedures which manipulate class objects, these proceduresare called "methods" (the term is again borrowed from theobject-oriented community). Nevertheless, the syntax of a method isthat of a procedure:method bar(param1,param2,param3,...) # Icon code which may access # fields of a class foo objectendSince execution of a class method is always associated with a givenobject of that class, the method has access to an implicit variablecalled self which is a record containing fields whose names arethose given in the class declaration. References to the self variablelook just like normal record references; they use the dot (.)operator. In addition to methods, classes may also contain regularIcon procedure, global, and record declarations; such declarationshave the standard semantics and exist in the global Icon name space. ObjectsLike records, instances of a class type are created with a constructorfunction whose name is that of the class. Instances of a class arecalled objects, and their fields may be initialized explicitly in theconstructor in exactly the same way as for records. For example,after defining a class foo(x,y) one may write:procedure main() f := foo(1,2)endThe fields of an object need not be initialized by the classconstructor. For many objects it is more logical to initialize theirfields to some standard value. In this case, the class declarationmay include an "initially" section after its methods are defined andb
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Object OOPS Folde
+++++ Continued from previous card +++++
efore its end.This section begins with a line containing the word "initially" andthen contains lines which are executed whenever an object of thatclass is constructed. These lines may reference and assign to theclass fields as if they were normal record fields for the object beingconstructed. The "record" being constructed is named self;more on self later.For example, suppose one wished to implement an enhanced table typewhich permitted sequential access to elements in the order they wereinserted into the table. This can be implemented by a combination ofa list and a table, both of which would initialized to the appropriateempty structure:class taque(l,t) # pronouned `taco' # methods to manipulate taques, # e.g. insert, lookup, foreach...initially self.l := [ ] self.t := table()endAnd in such a case one can create objects without including argumentsto the class constructor:procedure main() mytaque := taque()endIn the absence of an initially section, missing arguments to aconstructor default to the null value. Together with an initiallysection, the class declaration looks rather like a procedure thatconstructs objects of that class. Note that one may write classeswith some fields that are initialized explicitly by the constructorand other fields are initialized automatically in the initiallysection. In this case one must either declare the automaticallyinitialized fields after those that are initialized in theconstructor, or insert &null in the positions of theautomatically initialized fields in the constructor. Object InvocationOnce one has created an object with a class constructor, onemanipulates the object by invoking methods defined by its class.Since objects are both procedures and data, object invocation issimilar to both a procedure call and a record access. The dollar($) operator invokes one of an object's methods. It usedsimilarly to the dot (.) operator used to access record fields.Using the taque example:procedure main() mytaque := taque() mytaque$insert("greetings","hello") mytaque$insert(123) every write(mytaque$foreach()) if \(mytaque$lookup("hello")) then write(", world")endNote that direct access to an object's fields using the usual dot (.)operator is not possible outside of a method of the appropriate class.Attempts to reference mystack.l in procedure main() would result ina runtime error (invalid field name). Within a class method, theimplicit variable self allows access to the object's fields inthe usual manner. The taque insert method is thus: method insert(x,key) /key := x put(self.l,x) self.t[key] := x endThe self variable is both a record and an object. It allows fieldaccess just like a record, as well as method invocation like any otherobject. Thus class methods can use self to invoke other class methodswithout any special syntax. InheritanceIn many cases, two classes of objects are very similar. Inparticular, many classes can be thought of simply as enhancements ofsome class that has already been defined. Enhancements might take theform of added fields, added methods, or both. In other cases a classis just a special case of another class. For example, if one haddefined a class fraction(numerator, denominator), one might want todefine a class inverses(denominator) whose behavior was identical tothat of a fraction, but whose numerator was always 1.Idol supports both of these ideas with the concept of inheritance.When the definition of a class is best expressed in terms of thedefinition of another class or classes, we call that class a subclassof the other classes. This corresponds to the logical relation ofhyponymy. It means an object of the subclass can be manipulated justas if it were an object of one of its defining classes. In practicalterms it means that similar objects can share the code thatmanipulates their fields. The syntax of a subclass isclass foo : superclasses (fields...)# methods[optional initially section]end Multiple InheritanceThere are times when a new class might best be described as acombination of two or more classes. Idol classes may have more thanone superclass, separated by colons in the class declaration. This iscalled multiple inheritance.Subclasses define a record type consisting of all the fieldnames foundin the class itself and in all its superclasses. The subclass hasassociated methods consisting of those in its own body, those in thefirst superclass which were not defined in the subclass, those in thesecond superclass not defined in the subclass or the first superclass,and so on. Fields are initialized either by the constructor or by theinitially section of the first class of the class:superclass list inwhich the field is defined. For example, to define a class ofinverses in terms of a class fraction(numerator,denominator) onewould write:class inverse : fraction (denominator)initially self.numerator := 1endObjects of class inverse can be manipulated using all the methodsdefined in class fraction; the code is actually shared by both classesat runtime.Viewing inheritance as the addition of fieldnames and methods ofsuperclasses not already defined in the subclass is the opposite ofthe more traditional object-oriented view that a subclass starts withan instance of the superclass and augments or overrides portions ofthe definition with code in the subclass body. Idol's viewpoint addsquite a bit of leverage, such as the ability to define classes whichare subclasses of each other. This feature is described further below. Invoking Superclass OperationsWhen a subclass defines a method of the same name as a method definedin the superclass, invocations on subclass objects always result inthe subclass' version of the method. This can be overridden byexplicitly including the superclass name in the invocation:object$superclass.method(parameters)This facility allows the subclass method to do any additional workrequired for added fields before or after calling an appropriatesuperclass method to achieve inherited behavior. The result isfrequently a chain of inherited method invocations. Public FieldsAs noted above, there is a strong correspondence between records andclasses. Both define new types which extend Icon's built inrepertoire. For simple jobs, records are slightly faster as well asmore convenient: the user can directly read and write a record'sfields by name.Classes, on the other hand, promote the re-use of code and reduce thecomplexity required to understand or maintain large, involvedstructures. They should be used especially when manipulatingcomposite structures ontaining mixes of structures as elements, e.g.lists containing tables, sets, and lists in various positions.Sometimes it would be really nice to access fields in an objectdirectly, as with records. An example from the Idol program itself isthe name field associated with methods and classes---it is astring which is intended to be read outside the object. One canalways implement a method which returns (or assigns, for that matter)a field value, but this gets tedious. Idol currently supportsread-only access to fields via the public keyword. Ifpublic precedes a fieldname in a class declaration, Idolautomatically generates a method of the same name which dereferencesand returns the field. For example, the declarationclass sinner(pharisee,public publican)generates code equivalent to the following class method in additionto any explicitly defined methods: method publican() return .(self.publican) endThis feature, despite its utility and the best of intentions, makes itpossible to subvert object encapsulation: it should not beused with fields whose values are structures, since the structurecould then be modified from the outside. When invoked with the-strict option, Idol generates code for public methods whichchecks for a scalar type at runtime before returning the field. Superclass Cycles and Type EquivalenceIn many situations, there are several ways to represent the sameabstract type. Two-dimensional points might be represented byCartesian coordinates x and y, or equivalently by radial coordinatesexpressed as degree d and radian r. If one were implementing classescorresponding to these types there is no reason why one of them shouldbe considered a subclass of the other. The types are trulyinterchangeable and equivalent.In Idol, expressing thisequivalence is simple and direct. In defining classes Cartesianand Radian we may declare them to be superclasses of each other:class Cartesian : Radian (x,y)# code which manipulates objects using cartesian coordinatesendclass Radian : Cartesian (d,r)# code which manipulates objects using radian coordinatesendThese superclass declarations make the two types equivalent names forthe same type of object; after inheritance, instances of both classeswill have fields x,y,d, and r, and support the same set of operations.Equivalent types each have their own constructor given by their classname; although they export the same set of operations, the actualprocedures invoked by the different instances may be different. Forexample, if both classes define an implementation of a methodprint, the method invoked by a given instance depends onwhich constructor was used when the object was created.If a class inherits any methods from one of its equivalentclasses, it is responsible for initializing the state of allthe fields used by those methods in its own constructor, andmaintaining the state of the inherited fields when its methods makestate changes to its own fields. In the geometric example givenabove, in order for class Radian to use any methods inheritedfrom class Cartesian, it must at least initialize x and y explicityin its constructor from calculations on its d and r parameters.In general, this added responsibility is minimized in those classeswhich treat an object's state as a value rather than a structure.The utility of equivalent types expressed by superclass cycles remainsto be seen. At the least, they provide a convenient way to writeseveral alternative constructors for the same class of objects.Perhaps more importantly, their presence in Idol causes us to questionthe almost religious dogmatism that the superclass graph must alwaysbe acyclic. MiscellanyIdol supports some shorthand for convenient object invocation. Inparticular, if a class defines methods named size, foreach, random,or activate, these methods can be invoked by a modified version ofthe usual Icon operator:$*x is equivalent to x$size()$?x is equivalent to x$random()$!x is eq to x$foreach()$@x is equivalent to x$activate()Other operators may be added to this list. If x is an identifierit may be used directly; if it is a more complex expression (such as afunction call) it should be parenthesized, e.g.$*(complex_expression()).Parentheses are also required in the case of invoking an objectreturned from an invocation, e.g. (classes$lookup("theClass"))$name()These requirements are artifacts of the first implementation and aresubject to change.The Idol preprocessor is written in Idol and does not actually parsethe language it purports to implement. In particular, thepreprocessor is line-oriented and class and method declarations, theinitially keyword, and the class and method end keyword need to be ona line by themselves. Similarly, both the object being invoked andits method and parameters must be on the same line for invocations.The Idol preprocessor reserves certain names for internal use. Inparticular, __state and __methods are not legal classfield names. Similarly, the name idol_object is reserved in theglobal name space, and may not be used as a global variable, procedure,or record name. Finally, for each class foo amongst the user'scode, the names foo, foo___state, foo___methods,foo__oprec are reserved, as are the names foo__barcorresponding to each method bar in class foo. Thesedetails are artifacts of the current implementation and are subjectto change.Subclass constructors can be confusing, especially when multipleinheritance brings in various fields from different superclasses.One significant problem for users of the subclass is that theparameters expected in the constructor may not be obvious if theyare inherited from a superclass. On the other side of the spectrum,superclasses which automatically initialize their fields can beless than useful if the subclass might need to override thedefault initialization value--the subclass must then explicitlyname the field in order to make its initially section haveprecedence over the superclass.The first of the two problems given above can be solved by namingfields explicitly in a subclass when initialization by constructor.This achieves clarity at the expense of changing the inheritancebehavior, since the subclass no longer inherits the superclassautomatic initialization for that field if there is one. The latterof the two problems can generally be solved by using the / operatorin automatic field initializations unless the initialization shouldnever be overridden.While it is occasionally convenient to redeclare an inherited fieldin a subclass, accidentally doing so and then using that field to store anunrelated value would be disastrous. Although Idol offers no propersolution to this problem, the -strict option causes the generationof warning messages for each redefined field name noting the relevantsub- and superclasses. Running IdolIdol requires Version 7.5 or higher of Icon. It runs best on UNIXsystems. It has not been ported to all the various micros andoperating systems on which Icon 7.5 runs. In particular, if yourversion of Icon does not support the system() function, or yourmachine does not have adequate memory available, Idol will not beable to invoke icont to complete its translation and linking.Since Idol is untested on many systems, you may have to make smallchanges to the source code in order to port it to a new system. Getting a CopyIdol is in the public domain. It is available on the Icon BBS and byanonymous ftp from cs.arizona.edu. Idol is also distributed withthe program library for Version 8 of Icon and is available by mail inthis way. Interested parties may contact the author(cjeffery@cs.arizona.edu): Department of Computer Science University of Arizona Tucson, AZ 85721 Creating an Idol executableIdol is typically distributed in both Idol and Icon source forms.Creating an Idol executable requires a running version of Icon and acopy of idolboot.icn, the Icon source for Idol. A second Iconsource file contains the operating-system dependent portion of Idol;for example, unix.icn (see the Idol README file for the name ofyour system file if you are not on a UNIX system; you may have towrite your own, but it is not difficult). Using icont, compileidolboot.icn and unix.icn into an executable file (namedidolboot, or idolboot.icx). As a final step, rename thisexecutable to idol (or idol.icx). Installing the Idol Library MechanismFor each directory in which Idol source is kept, the Idol preprocessornormally uses a subdirectory to store its generated code on systemswhich support a hierarchical file system. On systems without ahierarchy, it stores generated code in the sou
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Object OOPS Folde
+++++ Continued from previous card +++++
rce directory. Beforeactually running Idol on any source files you should install theIdol libraries. This is done by invoking the commandidol -install(some systems use "iconx idol -install"). Follow anydirections given at this point; on most systems installation isentirely automatic. Translating Idol ProgramsThe syntax for invoking idol is normallyidol file1[.iol] [files...](on some systems you may have to say "iconx idol" where itsays "idol" above). The Idol translator creates a separateIcon file for each class in the Idol source files you give it. Onmost systems it calls icont automatically to create ucode for thesefiles. If the first file on the command line has any normal Icon codein it (in addition to any class definitions it may contain), Idolattempts to link it to any classes it may need and create an executable.The file extension defaults to .iol. Idol also acceptsextensions .icn, .u1, and .cl. The first two referto Icon source or already translated code for which Idol generateslink statements in the main (initial) Idol source file. Idol treatsarguments with the extension .cl as class names and generateslink statements for that class and its superclasses. References[Gris83]Griswold, R.E. and Griswold, M.T.The Icon Programming Language.Prentice-Hall, Englewood Cliffs, New Jersey, 1983.[Gris87]Griswold, R.E.Programming in Icon; Part I---Programming with Co-Expressions.Technical Report 87-6, Department of Computer Science, University of Arizona, June 1987.[Walk86]Walker, K.Dynamic Environments---A Generalization of Icon String Scanning.Technical Report 86-7, Department of Computer Science, University of Arizona, March 1986. :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Object OOPS Foldeidol.iol
# @(#)idol.iol 6.30 (3/14/90)## Idol: Icon-derived object language, version 6.30## SYNOPSIS:## idol -install# idol prog[.iol] ... [-x args ]# prog## FILES:## ./prog.iol : source file# ./prog.icn : Icon code for non-classes in prog.iol# ./idolcode.env/i_object.* : Icon code for the universal object type# ./idolcode.env/classname.icn : Icon files are generated for each class# ./idolcode.env/classname.u[12] : translated class files# ./idolcode.env/classname : class specification/interface## SEE ALSO:## "Programming in Idol: An Object Primer"# (U of Arizona Dept of CS Technical Report #90-10)# serves as user's guide and reference manual for Idol#### Global variables## FILES : fin = input (.iol) file, fout = output (.icn) file# CSETS : alpha = identifier characters, nonalpha = everything else# alphadot = identifiers + '.'# white = whitespace, nonwhite = everything else# TAQUES : classes in this module# FLAGS : comp if we should try to make an executable from args[1]# strict if we should generate paranoic encapsulation protection# loud if Idol should generate extra console messages# exec if we should run the result after translation# LISTS : links = names of external icon code to link to# imports = names of external classes to import# compiles = names of classes which need to be compiled#global fin,fout,fName,fLine,alpha,alphadot,white,nonwhite,nonalphaglobal classes,comp,exec,strict,links,imports,loud,compiles## initialize global variables#procedure initialize() loud := 1 comp := 0 alpha := &ucase ++ &lcase ++ '_' ++ &digits nonalpha := &cset -- alpha alphadot := alpha ++ '.' white := ' \t\014' nonwhite := &cset -- white classes := taque() links := [] imports := [] compiles := [] sysinitialize()end procedure main(args) initialize() if *args = 0 then write("usage: idol files...") else { every i := 1 to *args do { if \exec then next # after -x, args are for execution if args[i][1] == "-" then { case map(args[i]) of { "-c" : { sysok := &null if comp = 0 then comp := -1 # don't make exe } "-install": return install(args[1:i+1]) "-quiet" : loud := &null "-strict" : strict := 1 "-s" : sysok := &null "-t" : comp := -2 # don't translate "-version": return write("Idol version 6.30 of 3/14/90") & 0 "-x" : exec := i } } else if args[i][find(".cl",args[i]):0] := "" then push(imports,args[i]) else if args[i][find(".icn",args[i]):0] := "" then { push(links,args[i]) icont(" -c "||args[i]) } else if args[i][find(".u1",args[i]):0] := "" then push(links,args[i]) else if (args[i][find(".iol",args[i]):0] := "") | tryopen(args[i]||".iol","r") then { /exe := i args[i][find(".iol",args[i]):0] := "" /fout := sysopen(args[i]||".icn","w") readinput(args[i]||".iol",1) } else { # # let's go out and look for an appropriate .icn, .u1 or class file! # if tryopen(args[i]||".icn","r") then { push(links,args[i]) icont(" -c "||args[i]) } else if tryopen(args[i]||".u1") then push(links,args[i]) else if tryenvopen(args[i]) then push(imports,args[i]) } } gencode() close(\fout) if comp = 1 then makeexe(args,exe) }end ## gencode first generates specifications for all defined classes# It then imports those classes' specifications which it needs to# compute inheritance. Finally, it writes out all classes' .icn files.#procedure gencode() if \loud then write("Class import/export:") # # export specifications for each class # every cl := classes$foreach_t() do cl$writespec() # # import class specifications, transitively # repeat { added := 0 every super:= ((classes$foreach_t())$foreachsuper() | !imports) do{ if /classes$lookup(super) then { added := 1 fname := filename(super) readinput(envpath(fname),2) if /classes$lookup(super) then halt("can't import class '",super,"'") writesublink(fname) } } if added = 0 then break } # # compute the transitive closure of the superclass graph # every (classes$foreach_t())$transitive_closure() # # generate output # if \loud then write("Generating code:") writesublink("i_object") every s := !links do writelink(s) write(fout) every out := $!classes do { name := filename(out$name()) out$write() put(compiles,name) writesublink(name) } if *compiles>0 then cdicont(compiles)end ## a class defining objects resulting from parsing lines of the form# tag name ( field1 , field2, ... )# If the constructor is given an argument, it is passed to self$read#class declaration(public name,fields,tag) # # parse a declaration string into its components # method read(decl) decl ? { # get my tag tab(many(white)) if not (self.tag := =("procedure"|"class"|"method"|"record")) then halt("declaration/read can't parse decl ",decl) tab(many(white)) # get my name if not (self.name := tab(many(alpha))) then halt("declaration/read can't parse decl ",decl) # get my fields if not tab(find("(")+1) then halt("declaration/read can't parse decl ",decl) tab(many(white)) self.fields := classFields() if not (self.fields$parse(tab(find(")")))) then halt("declaration/read can't parse decl ",decl) } end # # write a declaration; at the moment, only used by records # method write(f) write(f,self$String()) end # # convert self to a string # method String() return self.tag || " " || self.name || "(" || self.fields$String() || ")" endinitially if \self.name then self$read(self.name)end ## class body manages a list of strings holding the code for# procedures/methods/classes#class body(fn,ln,text) method read() self.fn := fName self.ln := fLine self.text := [] while line := readln() do { put(self.text, line) line ? { tab(many(white)); if ="end" & &pos > *line then return } } halt("body/read: eof inside a procedure/method definition") end method write(f) if \self.ln then write(f,"#line ",self.ln," \"",self.fn,"\"") every write(f,$!self) end method delete() return pull(self.text) end method size() return (*\ (self.text)) | 0 end method foreach() if t := \self.text then suspend !self.text endend ## a class defining operations on classes#class class : declaration (supers,methods,text,imethods,ifields,glob) # imethods and ifields are all lists of these: record classident(class,ident) method read(line,phase) self$declaration.read(line) self.supers := idTaque(":") self.supers$parse(line[find(":",line)+1:find("(",line)] | "") self.methods:= taque() self.text := body() while line := readln() do { line ? { tab(many(white)) if ="initially" then { self.text$read() if phase=2 then return self.text$delete() # "end" appended manually during writing after # generation of the appropriate return value return } else if ="method" then { decl := method(self.name) decl$read(line,phase) self.methods$insert(decl,decl$name()) } else if ="end" then { # "end" is tossed here. see "initially" above return } else if ="procedure" then { decl := Procedure("") decl$read(line,phase) /self.glob := [] put(self.glob,decl) } else if ="global" then { /self.glob := [] put(self.glob,Global(line)) } else if ="record" then { /self.glob := [] put(self.glob,declaration(line)) } else if upto(nonwhite) then { halt("class/read expected declaration on: ",line) } } } halt("class/read syntax error: eof inside a class definition") end # # Miscellaneous methods on classes # method has_initially() return $*self.text > 0 end method ispublic(fieldname) if self.fields$ispublic(fieldname) then return fieldname end method foreachmethod() suspend $!self.methods end method foreachsuper() suspend $!self.supers end method foreachfield() suspend $!self.fields end method transitive_closure() count := $*self.supers while count > 0 do { added := taque() every sc := $!self.supers do { if /(super := classes$lookup(sc)) then halt("class/transitive_closure: couldn't find superclass ",sc) every supersuper := super$foreachsuper() do { if / self.supers$lookup(supersuper) & /added$lookup(supersuper) then { added$insert(supersuper) } } } count := $*added every self.supers$insert($!added) } end # # write the class declaration: if s is "class" write as a spec # otherwise, write as a constructor # method writedecl(f,s) writes(f, s," ",self.name) if s=="class" & ( *(supers := self.supers$String()) > 0 ) then writes(f," : ",supers) writes(f,"(") rv := self.fields$String(s) if *rv > 0 then rv ||:= "," if s~=="class" & \self.ifields then # inherited fields every l := !self.ifields do rv ||:= l.ident || "," writes(f,rv[1:-1]) write(f,,")") end method writespec(f) # write the specification of a class f := envopen(filename(self.name),"w") self$writedecl(f,"class") every ($!self.methods)$writedecl(f,"method") if self$has_initially() then write(f,"initially") write(f,"end") close(f) end # # write out the Icon code for this class' explicit methods # and its "nested global" declarations (procedures, records, etc.) # method writemethods() f:= envopen(filename(self.name)||".icn","w") every ($!self.methods)$write(f,self.name) if \self.glob & *self.glob>0 then { write(f,"#\n# globals declared within the class\n#") every i := 1 to *self.glob do (self.glob[i])$write(f,"") } close(f) end # # write - write an Icon implementation of a class to file f # method write() f:= envopen(filename(self.name)||".icn","a") # # must have done inheritance computation to write things out # if /self.ifields then self$resolve() # # write a record containing the state variables # writes(f,"record ",self.name,"_state(__state,__methods") # reserved fields rv := "," rv ||:= self.fields$idTaque.String() # my fields if rv[-1] ~== "," then rv ||:= "," every s := (!self.ifields).ident do rv ||:= s || "," # inherited fields write(f,rv[1:-1],")") # # write a record containing the methods # writes(f,"record ",self.name,"_methods(") rv := "" every s := ((($!self.methods)$name()) | # my explicit methods self.fields$foreachpublic() | # my implicit methods (!self.imethods).ident | # my inherited methods $!self.supers) # super.method fields do rv ||:= s || "," if *rv>0 then rv[-1] := "" # trim trailling , write(f,rv,")") # # write a global containing this classes' operation record # along with declarations for all superclasses op records # writes(f,"global ",self.name,"__oprec") every writes(f,", ", $!self.supers,"__oprec") write(f) # # write the constructor procedure. # This is a long involved process starting with writing the declaration. # self$writedecl(f,"procedure") write(f,"local self,clone") # # initialize operation records for this and superclasses # write(f,"initial {\n", " if /",self.name,"__oprec then ",self.name,"initialize()") if $*self.supers > 0 then every (super <- $!self.supers) ~== self.name do write(f," if /",super,"__oprec then ",super,"initialize()\n", " ",self.name,"__oprec.",super," := ", super,"__oprec") write(f," }") # # create self, initialize from constructor parameters # writes(f," self := ",self.name,"_state(&null,",self.name,"__oprec") every writes(f,",",$!self.fields) if \self.ifields then every writes(f,",",(!self.ifields).ident) write(f,")\n self.__state := self") # # call my own initially section, if any # if $*self.text > 0 then write(f," ",self.name,"initially(self)") # # call superclasses' initially sections # if $*self.supers > 0 then { every (super <- $!self.supers) ~== self.name do { if (classes$lookup(super))$has_initially() then { if /madeclone := 1 then { write(f," clone := ",self.name,"_state()\n", " clone.__state := clone\n", " clone.__methods := ",self.name,"__oprec") } write(f," # inherited initialization from class ",super) write(f," every i := 2 to *self do clone[i] := self[i]\n", " ",super,"initially(clone)") every l := !self.ifields do { if l.class == super then write(f," self.",l.ident," := clone.",l.ident) } } } } # # return the pair that comprises the object: # a pointer to the instance (__mystate), and # a pointer to the class operation record # write(f," return idol_object(self,",self.name,"__oprec)\n", "end\n") # # write out class initializer procedure to initialize my operation record # write(f,"procedure ",self.name,"initialize()") writes(f," initial ",self.name,"__oprec := ",self.name,"_methods") rv := "(" every s := ($!self.methods)$name() do { # explicit methods if *rv>1 then rv ||:= "," rv ||:= self.name||s } every me := self.fields$foreachpublic() do { # implicit methods if *rv>1 then rv ||:= "," # (for public fields) rv ||:= self.name||me } every l := !self.imethods do { # inherited methods if *rv>1 then rv ||:= "," rv ||:= l.class||l.ident } write(f,rv,")\n","end") # # write out initially procedure, if any # if self$has_initially() then { write(f,"procedure ",self.name,"initially(self)") self.text$write(f) write(f,"end") } # # write out implicit methods for public fields # every me := self.fields$foreachpublic() do { write(f,"procedure ",self.name,me,"(self)") if \strict then { write(f," if type(self.",me,") == ", "(\"list\"|\"table\"|\"set\"|\"record\") then\n", " runerr(501,\"idol: scalar type expected\")") } write(f," return .(self.",me,")") write(f,"end") write(f) } close(f) end # # resolve -- primary inheritance resolution utility # method resolve() # # these are lists of [class , ident] records # self.imethods := [] self.ifields := [] ipublics := [] addedfields := table() addedmethods := table() every sc := $!self.supers do { if /(superclass := classes$lookup(sc)) then halt("class/resolve: couldn't find superclass ",sc) every superclassfield := superclass$foreachfield() do { if /self.fields$lookup(superclassfield) & /addedfields[superclassfield] then { addedfields[superclassfield] := superclassfield put ( self.ifields , classident(sc,superclassfield) ) if superclass$ispublic(superclassfield) then put( ipublics, classident(sc,superclassfield) ) } else if \strict then { warn("class/resolve: '",sc,"' field '",superclassfield, "' is redeclared in subclass ",self.name) } } every superclassmethod := (superclass$foreachmethod())$name() do { if /self.methods$lookup(superclassmethod) & /addedmethods[superclassmethod] then { addedmethods[superclassmethod] := superclassmethod put ( self.imethods, classident(sc,superclassmethod) ) } } every public := (!ipublics) do { if public.class == sc then put (self.imethods, classident(sc,public.ident)) } } endend ## a
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Object OOPS Folde
+++++ Continued from previous card +++++
class defining operations on methods and procedures#class method : declaration (class,text) method read(line,phase) self$declaration.read(line) self.text := body() if phase = 1 then self.text$read() end method writedecl(f,s) decl := self$String() if s == "method" then decl[1:upto(white,decl)] := "method" else { decl[1:upto(white,decl)] := "procedure" decl[upto(white,decl)] ||:= self.class if *self.class ~= 0 then { i := find("(",decl) decl[i] ||:= "self" || (((decl[i+1] ~== ")"), ",") | "") } } write(f,decl) end method write(f) if self.name ~== "initially" then self$writedecl(f,"procedure") self.text$write(f) self.text := &null # after writing out text, forget it! endend## A class for ordinary Icon global declarations#class Global(s) method write(f) write(f,self.s) endend ## a class corresponding to an Icon table, with special treatment of empties#class Table(t) method size() return (* \ self.t) | 0 end method insert(x,key) /self.t := table() /key := x if / (self.t[key]) := x then return end method lookup(key) if t := \self.t then return t[key] return end method foreach() if t := \self.t then every suspend !self.t endend## tabular queues (taques):# a class defining objects which maintain synchronized list and table reps# Well, what is really provided are loosely-coordinated list/tables#class taque : Table (l) method insert(x,key) /self.l := [] if self$Table.insert(x,key) then put(self.l,x) end method foreach() if l := \self.l then every suspend !self.l end method insert_t(x,key) self$Table.insert(x,key) end method foreach_t() suspend self$Table.foreach() endend ## support for taques found as lists of ids separated by punctuation# constructor called with (separation char, source string)#class idTaque : taque(punc) method parse(s) s ? { tab(many(white)) while name := tab(find(self.punc)) do { self$insert(trim(name)) move(1) tab(many(white)) } if any(nonwhite) then self$insert(trim(tab(0))) } return end method String() if /self.l then return "" out := "" every id := !self.l do out ||:= id||self.punc return out[1:-1] endend ## parameter lists in which the final argument may have a trailing []#class argList : idTaque(public varg) method insert(s) if \self.varg then halt("variable arg must be final") if i := find("[",s) then { if not (j := find("]",s)) then halt("variable arg expected ]") s[i : j+1] := "" self.varg := s := trim(s) } self$idTaque.insert(s) end method String() return self$idTaque.String() || ((\self.varg & "[]") | "") endinitially self.punc := ","end## Idol class field lists in which fields may be preceded by a "public" keyword#class classFields : argList(publics) method String(s) if *(rv := self$argList.String())n return "" if /s | (s ~== "class") then return rv if self$ispublic(self.l[1]) then rv := "public "||rv every field:=self$foreachpublic() do rv[find(","||field,rv)] ||:= "public " return rv end method foreachpublic() if \self.publics then every suspend !self.publics end method ispublic(s) if \self.publics then every suspend !self.publics == s end method insert(s) s ? { if ="public" & tab(many(white)) then { s := tab(0) /self.publics := [] put(self.publics,s) } } self$argList.insert(s) endinitially self.punc := ","end ## tell whether the character following s is within a quote or not#procedure notquote(s) quotes := 0 outs := "" # this is a bug for people who write code like \"hello"... s ? { while outs ||:= tab(find("\\")+1) do { move(1) } outs ||:= tab(0) } s := outs outs := "" s ? { while outs ||:= tab(find("\""|"'")+1) do { quotes +:= 1 if tab(find(outs[-1])) then { quotes +:= 1 move(1) } } } if quotes % 2 = 0 then returnend ## filter the input translating $ references# (also eats comments and trims lines)#procedure readln() count := 0 if line := read(fin) then { fLine +:= 1 line[ 1(x<-find("#",line),notquote(line[1:x])) : 0] := "" line := trim(line) while ((x := find("$",line)) & notquote(line[1:x])) do { z := line[x+1:0] ||" " # " " is for bal() if find(line[x+1],"!*@?") then { # Invocation operators $! $* $@ $? z ? { move(1) tab(many(white)) if not (id := tab(many(alphadot))) then { if not match("(") then halt("readline can't parse ",line) if not (id := tab(&pos<bal())) then halt("readline: cant bal ",&subject) } case line[x+1] of { "@": Op := "activate" "*": Op := "size" "!": Op := "foreach" "?": Op := "random" default: halt("readline: unknown operator $",line[x+1]) } count +:= 1 line[x:0] := "(__self"||count||" := "||id||").__methods."|| Op||"(__self"||count||".__state)"||tab(0) } } else { reverse(line[1:x])||" " ? { tab(many(white)) if not (id := reverse(tab(many(alphadot)))) then { if not match(")") then halt("readline: can't parse") if not (id := reverse(tab(&pos<bal(&cset,')','(')))) then halt("readline: can't bal ",&subject) } nummatched := &pos-1 } if not (lp := find("(",z)) then halt("readline: expected '('") if z[lp+1] ~== ")" then c:="," else c:="" count +:= 1 line[x-nummatched : x+lp+1] := "(__self"||count||" := "||id||").__methods."|| z[1:lp+1]||"__self"||count||".__state"||c } } return line } else failend ## procedure to read a single Idol source file#procedure readinput(name,phase) if \loud then write("\t",name) fName := name fLine := 0 fin := sysopen(name,"r") while line := readln() do { line ? { tab(many(white)) if ="class" then { decl := class() decl$read(line,phase) if phase=1 then { decl$writemethods() classes$insert(decl,decl$name()) } else classes$insert_t(decl,decl$name()) } else if ="procedure" then { if comp = 0 then comp := 1 decl := method("") decl$read(line,phase) decl$write(fout,"") } else if ="record" then { if comp = 0 then comp := 1 decl := declaration(line) decl$write(fout,"") } else if ="global" then { if comp = 0 then comp := 1 decl := Global(line) decl$write(fout,"") } else if ="method" then { halt("readinput: method outside class") } } } close(fin)end ## error/warning/message handling#procedure halt(args[]) errsrc() every writes(&errout,!args) stop()endprocedure warn(args[]) errsrc() every writes(&errout,!args) write(&errout)endprocedure errsrc() writes(&errout,"\"",\fName,"\", line ",\fLine,": Idol/")end## System-independent, but system related routines#procedure tryopen(file,mode) if f := open(file,mode) then return close(f)endprocedure tryenvopen(file,mode) return tryopen(envpath(file),mode)endprocedure sysopen(file,mode) if not (f := open(file,mode)) then halt("Couldn't open file ",file," for mode ",mode) return fendprocedure envopen(file,mode) return sysopen(envpath(file),mode)endprocedure writelink(s) write(fout,"link \"",s,"\"")endprocedure icont(argstr,prefix)static sinitial { s := (getenv("ICONT")|"icont") } return mysystem(\prefix||s||argstr | s||argstr)end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Object OOPS Foldeidol.man
NAME idol - Icon-Derived Object LanguageSYNOPSIS idol -install idol [ option ... ] mainfile otherfiles... [-x arguments]DESCRIPTION Idol is an object-oriented preprocessor for Version 7.5+ Icon. It is a front-end for icont(1); typically one invokes idol on a source file (extension .iol) which is translated into an Icon source file (extension .icn) which is translated into a file suitable for interpretation by the Icon interpreter. Each directory containing Idol source files should be initialized by "idol -install" prior to translating any user sources. Producing an executable is skipped when the first file on the list contains only classes. The following options are recognized by idol: -c Suppress the linking phase -t Suppress all translation by icont -s Suppress removal of .icn files after translation by icont -quiet Suppress most Idol-specific console messages -install Install the Idol environment in the current directory -strict Generate code which is paranoid about ensuring encapsulation -version Print out the version of Idol and its date of creation The second and following files on the command line may include extensions .icn, .u1, and .cl. The first two Idol treats as Icon source code which should be translated and linked into the resulting executable. Files with extension .cl are treated as class names which are linked into the resulting executable. If no extension is given, Idol attempts to find the desired source file by appending .iol, .icn, .u1, or .cl in that order.FILES ./prog.iol : source file ./prog.icn : code generated for non-classes in prog.iol ./idolcode.env/i_object.* : Icon code for the universal object type ./idolcode.env/classname.icn : Icon files are generated for each class ./idolcode.env/classname.u[12] : translated class files ./idolcode.env/classname : class specification/interfaceSEE ALSO "Programming in Idol: An Object Primer" (U of Arizona Dept of CS Technical Report #90-10) serves as user's guide and reference manual for Idol :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Object OOPS Foldeidolboot.icn
global fin,fout,fName,fLine,alpha,alphadot,white,nonwhite,nonalphaglobal classes,comp,exec,strict,links,imports,loud,compilesprocedure initialize()#line 47 "idol.iol" loud := 1 comp := 0 alpha := &ucase ++ &lcase ++ '_' ++ &digits nonalpha := &cset -- alpha alphadot := alpha ++ '.' white := ' \t\014' nonwhite := &cset -- white classes := taque() links := [] imports := [] compiles := [] sysinitialize()endprocedure main(args)#line 62 "idol.iol" initialize() if *args = 0 then write("usage: idol files...") else { every i := 1 to *args do { if \exec then next if args[i][1] == "-" then { case map(args[i]) of { "-c" : { sysok := &null if comp = 0 then comp := -1 } "-install": return install(args[1:i+1]) "-quiet" : loud := &null "-strict" : strict := 1 "-s" : sysok := &null "-t" : comp := -2 "-version": return write("Idol version 6.30 of 3/14/90") & 0 "-x" : exec := i } } else if args[i][find(".cl",args[i]):0] := "" then push(imports,args[i]) else if args[i][find(".icn",args[i]):0] := "" then { push(links,args[i]) icont(" -c "||args[i]) } else if args[i][find(".u1",args[i]):0] := "" then push(links,args[i]) else if (args[i][find(".iol",args[i]):0] := "") | tryopen(args[i]||".iol","r") then { /exe := i args[i][find(".iol",args[i]):0] := "" /fout := sysopen(args[i]||".icn","w") readinput(args[i]||".iol",1) } else { if tryopen(args[i]||".icn","r") then { push(links,args[i]) icont(" -c "||args[i]) } else if tryopen(args[i]||".u1") then push(links,args[i]) else if tryenvopen(args[i]) then push(imports,args[i]) } } gencode() close(\fout) if comp = 1 then makeexe(args,exe) }endprocedure gencode()#line 118 "idol.iol" if \loud then write("Class import/export:") every cl := (__self1 := classes).__methods.foreach_t(__self1.__state) do (__self2 := cl).__methods.writespec(__self2.__state) repeat { added := 0 every super:= ((__self2 := ((__self1 := classes).__methods.foreach_t(__self1.__state))).__methods.foreachsuper(__self2.__state) | !imports) do{ if /(__self1 := classes).__methods.lookup(__self1.__state,super) then { added := 1 fname := filename(super) readinput(envpath(fname),2) if /(__self1 := classes).__methods.lookup(__self1.__state,super) then halt("can't import class '",super,"'") writesublink(fname) } } if added = 0 then break } every (__self2 := ((__self1 := classes).__methods.foreach_t(__self1.__state))).__methods.transitive_closure(__self2.__state) if \loud then write("Generating code:") writesublink("i_object") every s := !links do writelink(s) write(fout) every out := (__self1 := classes).__methods.foreach(__self1.__state) do { name := filename((__self1 := out).__methods.name(__self1.__state)) (__self1 := out).__methods.write(__self1.__state) put(compiles,name) writesublink(name) } if *compiles>0 then cdicont(compiles)endprocedure notquote(s)#line 713 "idol.iol" quotes := 0 outs := "" s ? { while outs ||:= tab(find("\\")+1) do { move(1) } outs ||:= tab(0) } s := outs outs := "" s ? { while outs ||:= tab(find("\""|"'")+1) do { quotes +:= 1 if tab(find(outs[-1])) then { quotes +:= 1 move(1) } } } if quotes % 2 = 0 then returnendprocedure readln()#line 739 "idol.iol" count := 0 if line := read(fin) then { fLine +:= 1 line[ 1(x<-find("#",line),notquote(line[1:x])) : 0] := "" line := trim(line) while ((x := find("$",line)) & notquote(line[1:x])) do { z := line[x+1:0] ||" " if find(line[x+1],"!*@?") then { z ? { move(1) tab(many(white)) if not (id := tab(many(alphadot))) then { if not match("(") then halt("readline can't parse ",line) if not (id := tab(&pos<bal())) then halt("readline: cant bal ",&subject) } case line[x+1] of { "@": Op := "activate" "*": Op := "size" "!": Op := "foreach" "?": Op := "random" default: halt("readline: unknown operator $",line[x+1]) } count +:= 1 line[x:0] := "(__self"||count||" := "||id||").__methods."|| Op||"(__self"||count||".__state)"||tab(0) } } else { reverse(line[1:x])||" " ? { tab(many(white)) if not (id := reverse(tab(many(alphadot)))) then { if not match(")") then halt("readline: can't parse") if not (id := reverse(tab(&pos<bal(&cset,')','(')))) then halt("readline: can't bal ",&subject) } nummatched := &pos-1 } if not (lp := find("(",z)) then halt("readline: expected '('") if z[lp+1] ~== ")" then c:="," else c:="" count +:= 1 line[x-nummatched : x+lp+1] := "(__self"||count||" := "||id||").__methods."|| z[1:lp+1]||"__self"||count||".__state"||c } } return line } else failendprocedure readinput(name,phase)#line 795 "idol.iol" if \loud then write("\t",name) fName := name fLine := 0 fin := sysopen(name,"r") while line := readln() do { line ? { tab(many(white)) if ="class" then { decl := class() (__self1 := decl).__methods.read(__self1.__state,line,phase) if phase=1 then { (__self1 := decl).__methods.writemethods(__self1.__state) (__self1 := classes).__methods.insert(__self1.__state,decl,(__self2 := decl).__methods.name(__self2.__state)) } else (__self1 := classes).__methods.insert_t(__self1.__state,decl,(__self2 := decl).__methods.name(__self2.__state)) } else if ="procedure" then { if comp = 0 then comp := 1 decl := method("") (__self1 := decl).__methods.read(__self1.__state,line,phase) (__self1 := decl).__methods.write(__self1.__state,fout,"") } else if ="record" then { if comp = 0 then comp := 1 decl := declaration(line) (__self1 := decl).__methods.write(__self1.__state,fout,"") } else if ="global" then { if comp = 0 then comp := 1 decl := Global(line) (__self1 := decl).__methods.write(__self1.__state,fout,"") } else if ="method" then { halt("readinput: method outside class") } } } close(fin)endprocedure halt(args[])#line 838 "idol.iol" errsrc() every writes(&errout,!args) stop()endprocedure warn(args[])#line 844 "idol.iol" errsrc() every writes(&errout,!args) write(&errout)endprocedure errsrc()#line 850 "idol.iol" writes(&errout,"\"",\fName,"\", line ",\fLine,": Idol/")endprocedure tryopen(file,mode)#line 856 "idol.iol" if f := open(file,mode) then return close(f)endprocedure tryenvopen(file,mode)#line 859 "idol.iol" return tryopen(envpath(file),mode)endprocedure sysopen(file,mode)#line 862 "idol.iol" if not (f := open(file,mode)) then halt("Couldn't open file ",file," for mode ",mode) return fendprocedure envopen(file,mode)#line 867 "idol.iol" return sysopen(envpath(file),mode)endprocedure writelink(s)#line 870 "idol.iol" write(fout,"link \"",s,"\"")endprocedure icont(argstr,prefix)#line 873 "idol.iol"static sinitial { s := (getenv("ICONT")|"icont") } return mysystem(\prefix||s||argstr | s||argstr)endrecord idol_object(__state,__methods)procedure declarationread(self,decl)#line 169 "idol.iol" decl ? { tab(many(white)) if not (self.tag := =("procedure"|"class"|"method"|"record")) then halt("declaration/read can't parse decl ",decl) tab(many(white)) if not (self.name := tab(many(alpha))) then halt("declaration/read can't parse decl ",decl) if not tab(find("(")+1) then halt("declaration/read can't parse decl ",decl) tab(many(white)) self.fields := classFields() if not ((__self1 := self.fields).__methods.parse(__self1.__state,tab(find(")")))) then halt("declaration/read can't parse decl ",decl) } endprocedure declarationwrite(self,f)#line 192 "idol.iol" write(f,(__self1 := self).__methods.String(__self1.__state)) endprocedure declarationString(self)#line 198 "idol.iol" return self.tag || " " || self.name || "(" || (__self1 := self.fields).__methods.String(__self1.__state) || ")" endrecord declaration_state(__state,__methods,name,fields,tag)record declaration_methods(read,write,String,name)global declaration__oprecprocedure declaration(name,fields,tag)local self,cloneinitial { if /declaration__oprec then declarationinitialize() } self := declaration_state(&null,declaration__oprec,name,fields,tag) self.__state := self declarationinitially(self) return idol_object(self,declaration__oprec)endprocedure declarationinitialize() initial declaration__oprec := declaration_methods(declarationread,declarationwrite,declarationString,declarationname)endprocedure declarationinitially(self)#line 201 "idol.iol" if \self.name then (__self1 := self).__methods.read(__self1.__state,self.name)endprocedure declarationname(self) return .(self.name)endprocedure bodyread(self)#line 210 "idol.iol" self.fn := fName self.ln := fLine self.text := [] while line := readln() do { put(self.text, line) line ? { tab(many(white)); if ="end" & &pos > *line then return } } halt("body/read: eof inside a procedure/method definition") endprocedure bodywrite(self,f)#line 220 "idol.iol" if \self.ln then write(f,"#line ",self.ln," \"",self.fn,"\"") every write(f,(__self1 := self).__methods.foreach(__self1.__state)) endprocedure bodydelete(self)#line 224 "idol.iol" return pull(self.text) endprocedure bodysize(self)#line 227 "idol.iol" return (*\ (self.text)) | 0 endprocedure bodyforeach(self)#line 230 "idol.iol" if t := \self.text then suspend !self.text endrecord body_state(__state,__methods,fn,ln,text)record body_methods(read,write,delete,size,foreach)global body__oprecprocedure body(fn,ln,text)local self,cloneinitial { if /body__oprec then bodyinitialize() } self := body_state(&null,body__oprec,fn,ln,text) self.__state := self return idol_object(self,body__oprec)endprocedure bodyinitialize() initial body__oprec := body_methods(bodyread,bodywrite,bodydelete,bodysize,bodyforeach)endprocedure classread(self,line,phase)#line 242 "idol.iol" (__self1 := self).__methods.declaration.read(__self1.__state,line) self.supers := idTaque(":") (__self1 := self.supers).__methods.parse(__self1.__state,line[find(":",line)+1:find("(",line)] | "") self.methods:= taque() self.text := body() while line := readln() do { line ? { tab(many(white)) if ="initially" then { (__self1 := self.text).__methods.read(__self1.__state) if phase=2 then return (__self1 := self.text).__methods.delete(__self1.__state) return } else if ="method" then { decl := method(self.name) (__self1 := decl).__methods.read(__self1.__state,line,phase) (__self1 := self.methods).__methods.insert(__self1.__state,decl,(__self2 := decl).__methods.name(__self2.__state)) } else if ="end" then { return } else if ="procedure" then { decl := Procedure("") (__self1 := decl).__methods.read(__self1.__state,line,phase) /self.glob := [] put(self.glob,decl) } else if ="global" then { /self.glob := [] put(self.glob,Global(line)) } else if ="record" then { /self.glob := [] put(self.glob,declaration(line)) } else if upto(nonwhite) then { halt("class/read expected declaration on: ",line) } } } halt("class/read syntax error: eof inside a class definition") endprocedure classhas_initially(self)#line 286 "idol.iol" return (__self1 := self.text).__methods.size(__self1.__state) > 0 endprocedure classispublic(self,fieldname)#line 289 "idol.iol" if (__self1 := self.fields).__methods.ispublic(__self1.__state,fieldname) then return fieldname endprocedure classforeachmethod(self)#line 292 "idol.iol" suspend (__self1 := self.methods).__methods.foreach(__self1.__state) endprocedure classforeachsuper(self)#line 295 "idol.iol" suspend (__self1 := self.supers).__methods.foreach(__self1.__state) endprocedure classforeachfield(self)#line 298 "idol.iol" suspend (__self1 := self.fields).__methods.foreach(__self1.__state) endprocedure classtransitive_closure(self)#line 301 "idol.iol" count := (__self1 := self.supers).__methods.size(__self1.__state) while count > 0 do { added := taque() every sc := (__self1 := self.supers).__methods.foreach(__self1.__state) do { if /(super := (__self1 := classes).__methods.lookup(__self1.__state,sc)) then halt("class/transitive_closure: couldn't find superclass ",sc) every supersuper := (__self1 := super).__methods.foreachsuper(__self1.__state) do { if / (__self1 := self.supers).__methods.lookup(__self1.__state,supersuper) & /(__self1 := added).__methods.lookup(__self1.__state,supersuper) then { (__self1 := added).__methods.insert(__self1.__state,supersuper) } } } count := (__self1 := added).__methods.size(__self1.__state) every (__self1 := self.supers).__methods.insert(__self1.__state,(__self2 := added).__methods.foreach(__self2.__state)) } endprocedure classwritedecl(self,f,s)#line 323 "idol.iol" writes(f, s," ",self.name) if s=="class" & ( *(supers := (__self1 := self.supers).__methods.String(__self1.__state)) > 0 ) then writes(f," : ",supers) writes(f,"(") rv := (__self1 := self.fields).__methods.String(__self1.__state,s) if *rv > 0 then rv ||:= "," if s~=="class" & \self.ifields then every l := !self.ifields do rv ||:= l.ident || "," writes(f,rv[1:-1]) write(f,,")") endprocedure classwritespec(self,f)#line 335 "idol.iol" f := envopen(filename(self.name),"w") (__self1 := self).__methods.writedecl(__self1.__state,f,"class") every (__self2 := ((__self1 := self.methods).__methods.foreach(__self1.__state))).__methods.writedecl(__self2.__state,f,"method") if (__self1 := self).__methods.has_initially(__self1.__state) then write(f,"initially") write(f,"end") close(f) endprocedure classwritemethods(self)#line 348 "idol.iol" f:= envopen(filename(self.name)||".icn","w") every (__self2 := ((__self1 := self.methods).__methods.foreach(__self1.__state))).__methods.write(__self2.__state,f,self.name) if \self.glob & *self.glob>0 then { write(f,"#\n# globals declared within the class\n#") every i := 1 to *self.glob do (__self1 := (self.glob[i])).__methods.write(__self1.__state,f,"") } close(f) endprocedure classwrite(self)#line 362 "idol.iol" f:= envopen(filename(self.name)||".icn","a") if /self.ifields then (__self1 := self).__methods.resolve(__self1.__state) writes(f,"record ",self.name,"_state(__state,__methods") rv := "," rv ||:= (__self1 := self.fields).__methods.idTaque.String(__self1.__state) if rv[-1] ~== "," then rv ||:= "," every s := (!self.ifields).ident do rv ||:= s || "," write(f,rv[1:-1],")") writes(f,"record ",self.name,"_methods(") rv := "" every s := (((__self2 := ((__self1 := self.methods).__methods.foreach(__self1.__state))).__methods.name(__self2.__state)) | (__self1 := self.fields).__methods.foreachpublic(__self1.__state) | (!self.imethods).ident | (__self1 := self.supers).__methods.foreach(__self1.__state)) do rv ||:= s || "," if *rv>0 then rv[-1] := "" write(f,rv,")") writes(f,"global ",self.name,"__oprec") every writes(f,", ", (__self1 := self.supers).__methods.foreach(__self1.__state),"__oprec") write(f) (__self1 := self).__methods.writedecl(__self1.__state,f,"procedure") write(f,"local self,clone") write(f,"initial {\n", " if /",self.name,"__oprec then ",self.name,"initialize()") if (__self1 := self.supe
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Object OOPS Folde
+++++ Continued from previous card +++++
rs).__methods.size(__self1.__state) > 0 then every (super <- (__self1 := self.supers).__methods.foreach(__self1.__state)) ~== self.name do write(f," if /",super,"__oprec then ",super,"initialize()\n", " ",self.name,"__oprec.",super," := ", super,"__oprec") write(f," }") writes(f," self := ",self.name,"_state(&null,",self.name,"__oprec") every writes(f,",",(__self1 := self.fields).__methods.foreach(__self1.__state)) if \self.ifields then every writes(f,",",(!self.ifields).ident) write(f,")\n self.__state := self") if (__self1 := self.text).__methods.size(__self1.__state) > 0 then write(f," ",self.name,"initially(self)") if (__self1 := self.supers).__methods.size(__self1.__state) > 0 then { every (super <- (__self1 := self.supers).__methods.foreach(__self1.__state)) ~== self.name do { if (__self2 := ((__self1 := classes).__methods.lookup(__self1.__state,super))).__methods.has_initially(__self2.__state) then { if /madeclone := 1 then { write(f," clone := ",self.name,"_state()\n", " clone.__state := clone\n", " clone.__methods := ",self.name,"__oprec") } write(f," # inherited initialization from class ",super) write(f," every i := 2 to *self do clone[i] := self[i]\n", " ",super,"initially(clone)") every l := !self.ifields do { if l.class == super then write(f," self.",l.ident," := clone.",l.ident) } } } } write(f," return idol_object(self,",self.name,"__oprec)\n", "end\n") write(f,"procedure ",self.name,"initialize()") writes(f," initial ",self.name,"__oprec := ",self.name,"_methods") rv := "(" every s := (__self2 := ((__self1 := self.methods).__methods.foreach(__self1.__state))).__methods.name(__self2.__state) do { if *rv>1 then rv ||:= "," rv ||:= self.name||s } every me := (__self1 := self.fields).__methods.foreachpublic(__self1.__state) do { if *rv>1 then rv ||:= "," rv ||:= self.name||me } every l := !self.imethods do { if *rv>1 then rv ||:= "," rv ||:= l.class||l.ident } write(f,rv,")\n","end") if (__self1 := self).__methods.has_initially(__self1.__state) then { write(f,"procedure ",self.name,"initially(self)") (__self1 := self.text).__methods.write(__self1.__state,f) write(f,"end") } every me := (__self1 := self.fields).__methods.foreachpublic(__self1.__state) do { write(f,"procedure ",self.name,me,"(self)") if \strict then { write(f," if type(self.",me,") == ", "(\"list\"|\"table\"|\"set\"|\"record\") then\n", " runerr(501,\"idol: scalar type expected\")") } write(f," return .(self.",me,")") write(f,"end") write(f) } close(f) endprocedure classresolve(self)#line 513 "idol.iol" self.imethods := [] self.ifields := [] ipublics := [] addedfields := table() addedmethods := table() every sc := (__self1 := self.supers).__methods.foreach(__self1.__state) do { if /(superclass := (__self1 := classes).__methods.lookup(__self1.__state,sc)) then halt("class/resolve: couldn't find superclass ",sc) every superclassfield := (__self1 := superclass).__methods.foreachfield(__self1.__state) do { if /(__self1 := self.fields).__methods.lookup(__self1.__state,superclassfield) & /addedfields[superclassfield] then { addedfields[superclassfield] := superclassfield put ( self.ifields , classident(sc,superclassfield) ) if (__self1 := superclass).__methods.ispublic(__self1.__state,superclassfield) then put( ipublics, classident(sc,superclassfield) ) } else if \strict then { warn("class/resolve: '",sc,"' field '",superclassfield, "' is redeclared in subclass ",self.name) } } every superclassmethod := (__self2 := ((__self1 := superclass).__methods.foreachmethod(__self1.__state))).__methods.name(__self2.__state) do { if /(__self1 := self.methods).__methods.lookup(__self1.__state,superclassmethod) & /addedmethods[superclassmethod] then { addedmethods[superclassmethod] := superclassmethod put ( self.imethods, classident(sc,superclassmethod) ) } } every public := (!ipublics) do { if public.class == sc then put (self.imethods, classident(sc,public.ident)) } } end## globals declared within the class#record classident(class,ident)record class_state(__state,__methods,supers,methods,text,imethods,ifields,glob,name,fields,tag)record class_methods(read,has_initially,ispublic,foreachmethod,foreachsuper,foreachfield,transitive_closure,writedecl,writespec,writemethods,write,resolve,String,name,declaration)global class__oprec, declaration__oprecprocedure class(supers,methods,text,imethods,ifields,glob,name,fields,tag)local self,cloneinitial { if /class__oprec then classinitialize() if /declaration__oprec then declarationinitialize() class__oprec.declaration := declaration__oprec } self := class_state(&null,class__oprec,supers,methods,text,imethods,ifields,glob,name,fields,tag) self.__state := self clone := class_state() clone.__state := clone clone.__methods := class__oprec # inherited initialization from class declaration every i := 2 to *self do clone[i] := self[i] declarationinitially(clone) self.name := clone.name self.fields := clone.fields self.tag := clone.tag return idol_object(self,class__oprec)endprocedure classinitialize() initial class__oprec := class_methods(classread,classhas_initially,classispublic,classforeachmethod,classforeachsuper,classforeachfield,classtransitive_closure,classwritedecl,classwritespec,classwritemethods,classwrite,classresolve,declarationString,declarationname)endprocedure methodread(self,line,phase)#line 556 "idol.iol" (__self1 := self).__methods.declaration.read(__self1.__state,line) self.text := body() if phase = 1 then (__self1 := self.text).__methods.read(__self1.__state) endprocedure methodwritedecl(self,f,s)#line 562 "idol.iol" decl := (__self1 := self).__methods.String(__self1.__state) if s == "method" then decl[1:upto(white,decl)] := "method" else { decl[1:upto(white,decl)] := "procedure" decl[upto(white,decl)] ||:= self.class if *self.class ~= 0 then { i := find("(",decl) decl[i] ||:= "self" || (((decl[i+1] ~== ")"), ",") | "") } } write(f,decl) endprocedure methodwrite(self,f)#line 575 "idol.iol" if self.name ~== "initially" then (__self1 := self).__methods.writedecl(__self1.__state,f,"procedure") (__self1 := self.text).__methods.write(__self1.__state,f) self.text := &null endrecord method_state(__state,__methods,class,text,name,fields,tag)record method_methods(read,writedecl,write,String,name,declaration)global method__oprec, declaration__oprecprocedure lass,text,name,fields,tag)local self,cloneinitial { if /method__oprec then methodinitialize() if /declaration__oprec then declarationinitialize() method__oprec.declaration := declaration__oprec } self := method_state(&null,method__oprec,class,text,name,fields,tag) self.__state := self clone := method_state() clone.__state := clone clone.__methods := method__oprec # inherited initialization from class declaration every i := 2 to *self do clone[i] := self[i] declarationinitially(clone) self.name := clone.name self.fields := clone.fields self.tag := clone.tag return idol_object(self,method__oprec)endprocedure methodinitialize() initial method__oprec := method_methods(methodread,methodwritedecl,methodwrite,declarationString,declarationname)endprocedure Globalwrite(self,f)#line 587 "idol.iol" write(f,self.s) endrecord Global_state(__state,__methods,s)record Global_methods(write)global Global__oprecprocedure Global(s)local self,cloneinitial { if /Global__oprec then Globalinitialize() } self := Global_state(&null,Global__oprec,s) self.__state := self return idol_object(self,Global__oprec)endprocedure Globalinitialize() initial Global__oprec := Global_methods(Globalwrite)endprocedure Tablesize(self)#line 596 "idol.iol" return (* \ self.t) | 0 endprocedure Tableinsert(self,x,key)#line 599 "idol.iol" /self.t := table() /key := x if / (self.t[key]) := x then return endprocedure Tablelookup(self,key)#line 604 "idol.iol" if t := \self.t then return t[key] return endprocedure Tableforeach(self)#line 608 "idol.iol" if t := \self.t then every suspend !self.t endrecord Table_state(__state,__methods,t)record Table_methods(size,insert,lookup,foreach)global Table__oprecprocedure Table(t)local self,cloneinitial { if /Table__oprec then Tableinitialize() } self := Table_state(&null,Table__oprec,t) self.__state := self return idol_object(self,Table__oprec)endprocedure Tableinitialize() initial Table__oprec := Table_methods(Tablesize,Tableinsert,Tablelookup,Tableforeach)endprocedure taqueinsert(self,x,key)#line 619 "idol.iol" /self.l := [] if (__self1 := self).__methods.Table.insert(__self1.__state,x,key) then put(self.l,x) endprocedure taqueforeach(self)#line 623 "idol.iol" if l := \self.l then every suspend !self.l endprocedure taqueinsert_t(self,x,key)#line 626 "idol.iol" (__self1 := self).__methods.Table.insert(__self1.__state,x,key) endprocedure taqueforeach_t(self)#line 629 "idol.iol" suspend (__self1 := self).__methods.Table.foreach(__self1.__state) endrecord taque_state(__state,__methods,l,t)record taque_methods(insert,foreach,insert_t,foreach_t,size,lookup,Table)global taque__oprec, Table__oprecprocedure taque(l,t)local self,cloneinitial { if /taque__oprec then taqueinitialize() if /Table__oprec then Tableinitialize() taque__oprec.Table := Table__oprec } self := taque_state(&null,taque__oprec,l,t) self.__state := self return idol_object(self,taque__oprec)endprocedure taqueinitialize() initial taque__oprec := taque_methods(taqueinsert,taqueforeach,taqueinsert_t,taqueforeach_t,Tablesize,Tablelookup)endprocedure idTaqueparse(self,s)#line 639 "idol.iol" s ? { tab(many(white)) while name := tab(find(self.punc)) do { (__self1 := self).__methods.insert(__self1.__state,trim(name)) move(1) tab(many(white)) } if any(nonwhite) then (__self1 := self).__methods.insert(__self1.__state,trim(tab(0))) } return endprocedure idTaqueString(self)#line 651 "idol.iol" if /self.l then return "" out := "" every id := !self.l do out ||:= id||self.punc return out[1:-1] endrecord idTaque_state(__state,__methods,punc,l,t)record idTaque_methods(parse,String,insert,foreach,insert_t,foreach_t,size,lookup,taque,Table)global idTaque__oprec, taque__oprec, Table__oprecprocedure idTaque(punc,l,t)local self,cloneinitial { if /idTaque__oprec then idTaqueinitialize() if /taque__oprec then taqueinitialize() idTaque__oprec.taque := taque__oprec if /Table__oprec then Tableinitialize() idTaque__oprec.Table := Table__oprec } self := idTaque_state(&null,idTaque__oprec,punc,l,t) self.__state := self return idol_object(self,idTaque__oprec)endprocedure idTaqueinitialize() initial idTaque__oprec := idTaque_methods(idTaqueparse,idTaqueString,taqueinsert,taqueforeach,taqueinsert_t,taqueforeach_t,Tablesize,Tablelookup)endprocedure argListinsert(self,s)#line 663 "idol.iol" if \self.varg then halt("variable arg must be final") if i := find("[",s) then { if not (j := find("]",s)) then halt("variable arg expected ]") s[i : j+1] := "" self.varg := s := trim(s) } (__self1 := self).__methods.idTaque.insert(__self1.__state,s) endprocedure argListString(self)#line 672 "idol.iol" return (__self1 := self).__methods.idTaque.String(__self1.__state) || ((\self.varg & "[]") | "") endrecord argList_state(__state,__methods,varg,punc,l,t)record argList_methods(insert,String,varg,parse,foreach,insert_t,foreach_t,size,lookup,idTaque,taque,Table)global argList__oprec, idTaque__oprec, taque__oprec, Table__oprecprocedure argList(varg,punc,l,t)local self,cloneinitial { if /argList__oprec then argListinitialize() if /idTaque__oprec then idTaqueinitialize() argList__oprec.idTaque := idTaque__oprec if /taque__oprec then taqueinitialize() argList__oprec.taque := taque__oprec if /Table__oprec then Tableinitialize() argList__oprec.Table := Table__oprec } self := argList_state(&null,argList__oprec,varg,punc,l,t) self.__state := self argListinitially(self) return idol_object(self,argList__oprec)endprocedure argListinitialize() initial argList__oprec := argList_methods(argListinsert,argListString,argListvarg,idTaqueparse,taqueforeach,taqueinsert_t,taqueforeach_t,Tablesize,Tablelookup)endprocedure argListinitially(self)#line 675 "idol.iol" self.punc := ","endprocedure argListvarg(self) return .(self.varg)endprocedure classFieldsString(self,s)#line 683 "idol.iol" if *(rv := (__self1 := self).__methods.argList.String(__self1.__state)) = 0 then return "" if /s | (s ~== "class") then return rv if (__self1 := self).__methods.ispublic(__self1.__state,self.l[1]) then rv := "public "||rv every field:=(__self1 := self).__methods.foreachpublic(__self1.__state) do rv[find(","||field,rv)] ||:= "public " return rv endprocedure classFieldsforeachpublic(self)#line 690 "idol.iol" if \self.publics then every suspend !self.publics endprocedure classFieldsispublic(self,s)#line 693 "idol.iol" if \self.publics then every suspend !self.publics == s endprocedure classFieldsinsert(self,s)#line 696 "idol.iol" s ? { if ="public" & tab(many(white)) then { s := tab(0) /self.publics := [] put(self.publics,s) } } (__self1 := self).__methods.argList.insert(__self1.__state,s) endrecord classFields_state(__state,__methods,publics,varg,punc,l,t)record classFields_methods(String,foreachpublic,ispublic,insert,varg,parse,foreach,insert_t,foreach_t,size,lookup,argList,idTaque,taque,Table)global classFields__oprec, argList__oprec, idTaque__oprec, taque__oprec, Table__oprecprocedure classFields(publics,varg,punc,l,t)local self,cloneinitial { if /classFields__oprec then classFieldsinitialize() if /argList__oprec then argListinitialize() classFields__oprec.argList := argList__oprec if /idTaque__oprec then idTaqueinitialize() classFields__oprec.idTaque := idTaque__oprec if /taque__oprec then taqueinitialize() classFields__oprec.taque := taque__oprec if /Table__oprec then Tableinitialize() classFields__oprec.Table := Table__oprec } self := classFields_state(&null,classFields__oprec,publics,varg,punc,l,t) self.__state := self classFieldsinitially(self) clone := classFields_state() clone.__state := clone clone.__methods := classFields__oprec # inherited initialization from class argList every i := 2 to *self do clone[i] := self[i] argListinitially(clone) self.varg := clone.varg return idol_object(self,classFields__oprec)endprocedure classFieldsinitialize() initial classFields__oprec := classFields_methods(classFieldsString,classFieldsforeachpublic,classFieldsispublic,classFieldsinsert,argListvarg,idTaqueparse,taqueforeach,taqueinsert_t,taqueforeach_t,Tablesize,Tablelookup)endprocedure classFieldsinitially(self)#line 706 "idol.iol" self.punc := ","end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Object OOPS Foldeinstall.bat
rem msdos Idol installationrem This compiles Idol in order to to test the systemicont -Sr1000 -SF30 -Si1000 idolboot msdosmkdir idolcode.enviconx idolboot -t -installchdir idolcode.envicont -c i_objectchdir ..iconx idolboot idol msdos.icnidolt :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Object OOPS Foldeinverse.iol
class inverse:fraction(d)initially self.n := 1endprocedure main() x := inverse(2) y := fraction(3,4) z := x$times(y) write("The decimal equivalent of ",z$asString(), " is ",trim(z$asReal(),'0'))end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Object OOPS Foldeitags.iol
# itags - an Icon/Idol tag generator by Nick Kline# hacks (such as this header comment) by Clint Jeffery# last edit: 12/13/89## the output is a sorted list of lines of the form# identifier owning_scope category_type filename lineno(:length)## owning scope is the name of the class or procedure or record in which# the tag is defined.# category type is the kind of tag; one of:# (global,procedure,record,class,method,param,obj_field,rec_field)#procedure main(args) local line, lineno, fout, i, fin, notvar, objects, actual_file, outlinesinitial { fout := open("ITAGS", "w") | stop("can't open ITAGS for writing"); outlines := [[0,0,0,0,0,0]] i := 1 notid := &cset -- &ucase -- &digits -- &lcase -- '_'}if(*args=0) then stop("usage: itags file1 [file2 ...]")while i <= *args do { fin := open(args[i],"r") | stop("could not open file ",args[i]," exiting") lineno := 1 objects := program( args[i] ) while line := read(fin) do { line[upto('#',line):0] := "" line ? { tab(many(' ')) if =("global") then { if(any(notid)) then every objects$addvar( getword(), lineno ) } if =("procedure") then if(any(notid)) then { objects$addproc( getword(), lineno ) objects$myline(tab(0),lineno) } if =("class") then if any(notid) then { objects$addclass( getword(), lineno ) objects$myline(tab(0),lineno) } if =("method") then { if any(notid) then { objects$addmethod( getword(), lineno ) objects$myline(tab(0),lineno) } } if =("local") then { if any(notid) then every objects$addvar( getword(), lineno ) } if =("static") then { if any(notid) then every objects$addstat( getword(), lineno ) } if =("record") then { if any(notid) then { objects$addrec( getword(), lineno ) objects$myline(tab(0),lineno) objects$endline( lineno) } } if =("end") then objects$endline(lineno) } lineno +:= 1 } objects$drawthyself(outlines) i +:= 1}# now process all the resulting linesevery i := 2 to *outlines do { outlines[i] := ( left(outlines[i][1],outlines[1][1]+1) || left(outlines[i][2],outlines[1][2]+1) || left(outlines[i][3],outlines[1][3]+1) || left(outlines[i][4],outlines[1][4]+1) || left(outlines[i][5],outlines[1][5]) || (if \outlines[i][6] then ":"||outlines[i][6] else ""))}outlines := outlines[2:0]outlines := sort(outlines)every write(fout,!outlines)endclass functions(name, lineno,vars,lastline, parent, params,stat,paramtype)method drawthyself(outfile)local k every k := !self.vars do emit(outfile, k[1], self.name, "local", self.parent$myfile(),k[2]) every k := !self.params do emit(outfile, k[1], self.name, self.paramtype, self.parent$myfile(),k[2]) every k := !self.stat do emit(outfile, k[1], self.name, "static", self.parent$myfile(),k[2])endmethod myline(line,lineno)local wordstatic ids, lettersinitial { ids := &lcase ++ &ucase ++ &digits ++ '_' letters := &ucase ++ &lcase}line ? while tab(upto(letters)) do { word := tab(many(ids)) self.params|||:= [[word,lineno]]}endmethod addstat(varname, lineno) self.stat|||:=[[varname, lineno]] returnendmethod addvar(varname, lineno) self.vars|||:=[[varname, lineno]] returnendmethod endline( lineno ) self.lastline := linenoendmethod resetcontext() self.parent$resetcontext()endinitially self.vars := [] self.params := [] self.stat := []end # end of class functionsclass proc : functions(name,lineno, parent,paramtype)method drawthyself(outfile) emit(outfile,self.name, "*" , "procedure", self.parent$myfile(),self.lineno, self.lastline-self.lineno+1) self$functions.drawthyself(outfile)endinitially self.paramtype := "param"end # of class procclass rec : functions(name, lineno, parent, line, paramtype)method drawthyself(outfile) emit(outfile,self.name, "*", "record", self.parent$myfile(), self.lineno) self$functions.drawthyself(outfile)endinitially paramtype := "rec_field"end # class recordclass program(public myfile, vars, proc, records, classes, curcontext, contextsave,globals)method endline( lineno ) self.curcontext$endline( lineno ) self.curcontext := pop(self.contextsave)endmethod myline( line,lineno) self.curcontext$myline( line,lineno)end method drawthyself(outfile) every k := !self.globals do emit(outfile,k[1], "*", "global", self.myfile,k[2]) every (!self.proc)$drawthyself(outfile) every (!self.records)$drawthyself(outfile) every (!self.classes)$drawthyself(outfile)endmethod addmethod(name, lineno) push(self.contextsave,self.curcontext) self.curcontext := self.curcontext$addmethod(name,lineno) returnendmethod addstat(varname, lineno) self.curcontext$addstat(varname, lineno)endmethod addvar(varname, lineno) if self.curcontext === self then self.globals|||:= [[varname,lineno]] else self.curcontext$addvar(varname,lineno) returnendmethod addproc(procname, lineno) push(self.contextsave, self.curcontext) self.curcontext := proc(procname, lineno, self) self.proc|||:= [self.curcontext] returnendmethod addrec(recname, lineno) push(self.contextsave, self.curcontext) self.curcontext := rec(recname, lineno,self) self.records|||:=[self.curcontext] returnendmethod addclass(classname, lineno) push(self.contextsave, self.curcontext) self.curcontext := class_(classname, lineno, self) self.classes|||:=[self.curcontext] returnendmethod resetcontext() self.curcontext := pop(self.contextsave)endinitially self.globals := [] self.proc := [] self.records := [] self.classes := [] self.curcontext := self self.contextsave := []end # end of class programclass class_ : functions (public name, lineno, parent, meth,paramtype)method myfile() return self.parent$myfile()endmethod addmethod(methname, lineno) self.meth|||:= [methods(methname, lineno, self)] return (self.meth[-1])endmethod drawthyself(outfile) emit(outfile,self.name, "*" , "class", self.parent$myfile(),self.lineno, self.lastline-self.lineno+1) every (!self.meth)$drawthyself(outfile) self$functions.drawthyself(outfile)endinitially self.meth := [] self.paramtype := "obj_field"end #end of class_class methods: functions(name, lineno, parent,paramtype)method drawthyself(outfile) emit(outfile,self.name, self.parent$name() , "method", self.parent$myfile(),self.lineno, self.lastline-self.lineno+1) self$functions.drawthyself(outfile)endinitially self.paramtype := "param"end #end of members classprocedure emit(outlist,ident, scope, type, filename, line, length) outlist[1][1] := outlist[1][1] < *ident outlist[1][2] := outlist[1][2] < *scope outlist[1][3] := outlist[1][3] < *type outlist[1][4] := outlist[1][4] < *filename outlist[1][5] := outlist[1][5] < *line outlist[1][6] := outlist[1][6] < *\length put( outlist, [ident,scope,type,filename,line,length] )endprocedure getword() local word static ids,letts initial { ids := &ucase ++ &lcase ++ &digits ++ '_' letts := &ucase ++ &lcase } while tab(upto(letts)) do { word := tab(many(ids)) suspend word }end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Object OOPS Foldelabelgen.iol
procedure main() label := labelgen("L",":") every i := 1 to 10 do write($@label)end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Object OOPS Foldemain.iol
procedure main() mydeque := Deque() mydeque$push("hello") mydeque$push("world") write("My deque is size ",mydeque$size()) every write("give me a ",mydeque$foreach()) write("A random element is ",mydeque$random()) write("getting ",mydeque$get()," popping ",mydeque$pop())end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Object OOPS Foldemakefile
## @(#)mpw.icn 1.2 3/13/90# OS-specific code for Macintosh MPW# Adapted from unix.icn by Charles Lakos#global lnkopt,env,sysokprocedure mysystem(s) if \loud then write(s) return system(s)endprocedure filename(s) return sendprocedure writesublink(s) writelink(env||"_"||s)endprocedure envpath(filename) return env||"_"||filenameend## Installation.# Uses hierarchical filesystem on some systems (see initialize)#procedure install(args) write("Installing idol environment with prefix ",env) fout := envopen("i_object.icn","w") write(fout,"record idol_object(__state,__methods)") close(fout) fout := &null cdicont(["i_object"])end procedure makeexe(args,i) exe := args[i] if icont(lnkopt||exe) = \sysok then { mysystem("delete "||exe||".icn") if \exec then { write("Executing:") every i := exec+1 to *args do exe ||:= " "||args[i] mysystem(exe) } }end## system-dependent compilation of idolfile.icn# (in the idol subdirectory, if there is one)#procedure cdicont(idolfiles) args := " -c" rms := "" every ifile := !idolfiles do args ||:= " " || envpath(ifile) every ifile := !idolfiles do rms ||:= " " || envpath(ifile) || ".icn" if comp = -2 then return # -t --> don't translate at all if icont(args,"") = \sysok then mysystem("delete "||rms)endprocedure sysinitialize() lnkopt := " -Sr500 -SF30 -Si1000 " env:= "C" sysok := 0 loud := &null write(&errout) write(&errout, "*** Select and run the following commands ***") write(&errout)endprocedure system(s) write(&errout,s) return sysokend :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Object OOPS Foldemsdos.icn
## @(#)msdos.icn 1.3 3/13/90# OS-specific code for MS-DOS Idol## For systems which cannot run icont from within an Icon program,# the approach is for Idol to generate a script/batch file to do this.#global lnkopt,cd,md,env,sysok,batfileprocedure mysystem(s) if /batfile then batfile := open("idolt.bat","w") if \loud then write(s) write(batfile,s) return sysok # system(s) # MS-DOS Icon is generally too big to use system()endprocedure filename(s) s[9:0] := "" return sendprocedure writesublink(s) writelink(env||"\\\\"||s)endprocedure envpath(filename) return env||"\\"||filenameend## Installation.# Uses hierarchical filesystem on some systems (see initialize)#procedure install(args) write("Installing idol environment in ",env) if env ~== "" then mysystem(md||env) if fout := envopen("i_object.icn","w") then { write(fout,"record idol_object(__state,__methods)") close(fout) } else { if not (fout := open("i_object.icn","w")) then stop("can't open i_object") write(fout,"record idol_object(__state,__methods)") close(fout) mysystem("copy i_object.icn "||env) mysystem("del i_object.icn") } fout := &null cdicont(["i_object"])end procedure makeexe(args,i) exe := args[i] if icont(lnkopt||exe) = \sysok then { if \exec then { write("Executing:") exe := "iconx "||exe every i := exec+1 to *args do exe ||:= " "||args[i] mysystem(exe) } }end## system-dependent compilation of idolfile.icn# (in the idol subdirectory, if there is one)#procedure cdicont(idolfiles) if comp = -2 then return # -t --> don't call icont at all args := " -c" rms := "" every ifile := !idolfiles do args ||:= " " || ifile every ifile := !idolfiles do rms ||:= " " || ifile || ".icn" mysystem("cd idolcode.env") icont(args) mysystem("cd ..")endprocedure sysinitialize() lnkopt := " -Sr500 -SF30 -Si1000 " cd := "cd " md := "mkdir " env := "idolcode.env" sysok := 0end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Object OOPS Foldeos2.icn
## @(#)os2.icn 1.3 3/13/90# OS-specific code for OS/2 Idol# Adapted from msdos.icn by cheyenne wills#global lnkopt,cd,md,env,sysokprocedure mysystem(s) if \loud then write(s) return system(s)endprocedure filename(s) s[9:0] := "" return sendprocedure writesublink(s) writelink(env||"\\\\"||s)endprocedure envpath(filename) return env||"\\"||filenameend## Installation.# Uses hierarchical filesystem on some systems (see initialize)#procedure install(args) write("Installing idol environment in ",env) if env ~== "" then mysystem(md||env) fout := envopen("i_object.icn","w") write(fout,"record idol_object(__state,__methods)") close(fout) fout := &null cdicont(["i_object"])end procedure makeexe(args,i) exe := args[i] if icont(lnkopt||exe) = \sysok then { mysystem((if find("UNIX",&features) then "rm " else "del ")||exe||".icn") if \exec then { write("Executing:") if not find("UNIX",&features) then exe := "iconx "||exe every i := exec+1 to *args do exe ||:= " "||args[i] mysystem(exe) } }end## system-dependent compilation of idolfile.icn# (in the idol subdirectory, if there is one)#procedure cdicont(idolfiles)initial { s := (getenv("ICONT")|"icont") } if comp = -2 then return # -t --> don't call icont at all args := " -c" rms := "" every ifile := !idolfiles do args ||:= " " || ifile every ifile := !idolfiles do rms ||:= " " || ifile || ".icn" cdcmd := open("idolenv.cmd","w") write(cdcmd,"@echo off") write(cdcmd,"cd idolcode.env") write(cdcmd,s,args) write(cdcmd,"if errorlevel 1 goto xit") every ifile := !idolfiles do write(cdcmd,"del ",ifile,".icn") write(cdcmd,":xit") write(cdcmd,"cd ..") close(cdcmd) mysystem("idolenv.cmd") mysystem("del idolenv.cmd")endprocedure sysinitialize() lnkopt := " -Sr500 -SF30 -Si1000 " cd := "cd " md := "mkdir " env := "idolcode.env" sysok := 0end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Object OOPS Foldepoint.iol
class Cartesian : Radian (x,y)initially if /(self.r) then { self.r := sqrt(self.x^2+self.y^2) self.d := 0 # this should really be some awful mess }endclass Radian : Cartesian(d,r)initially if /(self.x) then { self.x := 0 self.y := 0 }end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Object OOPS Foldereadme
This is the Idol public distribution directory.Read idol.man and idol.doc for details on running Idol.The Idol source is idol.iol; the Idol booting kit is idolboot.icn.In addition to these two files, there is a system-specific Icon filewhich must be linked in to produce an Idol executable: so far thereare files amiga.icn, mpw.icn, msdos.icn, os2.icn, unix.icn, and vms.icn.BUILDING IDOLIf you are running MS-DOS, the file install.bat contains the sequenceof commands necessary to build Idol. This sequence consists of:(1) Compile idolboot with a line such as icont -Sr1000 -SF30 -Si1000 idolboot msdos(2) Install an Idol environment directory with a line such as iconx idolboot -installFor MS-DOS, this generates a batch file named idolt.bat whichyou would then execute to create the environment directory.For other systems, idolboot creates the directory itself.(3) Translate Idol from its idol.iol source file with a line such as iconx idolboot idol msdos.icn(Again, on MS-DOS, this generates a batch file named idolt.batwhich you should then execute.)This makes a good initial test of the system's operation.In addition there are several other files with extension .iol; theseare unfinished fragments of Idol source code for your perusal.Contributions are of course welcome!Note that Idol is still a work in progress, and this must beconsidered a test distribution. Support for non-UNIX systems isminimally tested; feel free to add code to support your systemand send it in.The -strict flag not only generates paranoid code for public fieldaccess, it generates extra warning messages erited fieldsare named in a subclass.Mail cjeffery@cs.arizona.edu (or uunet!arizona!cjeffery)when you have questions or bug fixes for Idol. :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Object OOPS Foldeseqtest.iol
procedure main() decimal := sequence(255) hex := sequence("0123456789ABCDEF","0123456789ABCDEF") octal := sequence(3,7,7) character := sequence(string(&cset)) while write(right($@decimal,3)," ",$@hex," ",$@octal," ",image($@character))end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Object OOPS Foldesequence.iol
procedure sequence(bounds[ ]) return Sequence(bounds)endclass Sequence(bounds,indices) method max(i) elem := self.bounds[i] return (type(elem)== "integer",elem) | *elem-1 end method elem(i) elem := self.bounds[i] return (type(elem)== "integer",self.indices[i]) | elem[self.indices[i]+1] end method activate() top := *(self.indices) if self.indices[1] > self$max(1) then fail s := "" every i := 1 to top do { s ||:= self$elem(i) } repeat { self.indices[top] +:= 1 if top=1 | (self.indices[top] <= self$max(top)) then break self.indices[top] := 0 top -:= 1 } return s endinitially / (self.indices) := list(*self.bounds,0)end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Object OOPS Foldesystems.doc
This file contains system-dependent notes on Idol. Compiling idolbootfor your system now requires a command of the form icont -Sr1000 -SF30 -Si1000 idolboot systemwhere system is the name of your system (so far unix, msdos, os2, or vms).UNIXIf you are running UNIX, count yourself lucky!MSDOSDue to memory limitations, Idol for MS-DOS Icon does not use the system()function. Instead, it generates a batch file, idolt.bat, containing thesequence of commands required to finish the translation and linking ofthe output into executable icode. The batch file idol.bat runs idoland then calls idolt for you; it should suffice in ordinary situations.It is invoked as described in the man page and reference manual, e.g. C> idol idol msdosThe file install.bat performs the initial bootstrap translation of idol.Note that the translation scripts cannot automatically remove .icn files,so you may have to remove them manually if your disk space is precious.VMSIdol compiles and runs under VMS Icon version 7.0, but its a littleklunky; idol may fail to execute icont, or icont may fail to executeilink (under version 7.0). Unfortunately I do not have accessto a VMS machine running a current version of Icon. Note that thereare two DCL scripts in the distribution: vms.com is used by Idolinternally, while idol.com is a convenience script if icont failson your system when invoked from inside Idol. Rememberwhen specifying options to either idol or icont one must put quotesaround the argument in order for VMS to leave it alone!OS/2Cheyenne Wills has provided us all with an OS/2 system file!Although problems should be reported to me, the credit is all his.MPWCharles Lakos has provided a system file for Icon running under theMacintosh Programmer's Workshop. Icon source for class X is generatedas C_X.icn. After the Idol translation phase, the commands for theIcon translation have been written to the MPW Worksheet. They can simply be selected and run. Thanks Charles!AMIGAIdol runs fairly comfortably on Version 8 of Amiga Icon (it won't workwith Version 7.5 of Amiga Icon). Version 8 of Amiga Icon isn'tavailable at this writing, but probably will be by the time you read this.OTHERSPorting idol consists of writing a new system.icn file for your system.Take a look at unix.icn, vms.icn, os2.icn, mpw.icn, and msdos.icn. :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Object OOPS Foldeunix.icn
## @(#)unix.icn 1.3 3/13/90# OS-specific code for UNIX Idol#global lnkopt,env,sysokprocedure mysystem(s) if \loud then write(s) return system(s)endprocedure filename(s) s[9:0] := "" return sendprocedure writesublink(s) writelink(env||"/"||s)endprocedure envpath(filename) return env||"/"||filenameend## Installation.# Uses hierarchical filesystem on some systems (see initialize)#procedure install(args) write("Installing idol environment in ",env) if env ~== "" then mysystem("mkdir "||env) fout := envopen("i_object.icn","w") write(fout,"record idol_object(__state,__methods)") close(fout) fout := &null cdicont(["i_object"])end procedure makeexe(args,i) exe := args[i] if icont(lnkopt||exe) = \sysok then { mysystem("rm "||exe||".icn") if \exec then { write("Executing:") every i := exec+1 to *args do exe ||:= " "||args[i] mysystem(exe) } }end## system-dependent compilation of idolfile.icn# (in the idol subdirectory, if there is one)#procedure cdicont(idolfiles) args := " -c" rms := "" every ifile := !idolfiles do args ||:= " " || ifile every ifile := !idolfiles do rms ||:= " " || ifile || ".icn" if comp = -2 then return # -t --> don't translate at all if icont(args,"cd idolcode.env; ") = \sysok then mysystem("cd idolcode.env; rm "||rms)endprocedure sysinitialize() lnkopt := " -Sr500 -SF30 -Si1000 " env:= "idolcode.env" sysok := 0end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Object OOPS Foldevms.com
$ ! A script used internally by Idol on VMS$ set default [.idolenv]$ icont -c 'P1'$ set default [-] :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Object OOPS Foldevms.icn
## @(#)vms.icn 1.4 3/13/90# OS-specific code for VMS Idol#global lnkopt,cd,md,env,sysokprocedure mysystem(s) if \loud then write(s) return system(s)endprocedure filename(s) s[9:0] := "" return sendprocedure writesublink(s) writelink(env||s)endprocedure envpath(filename) return env||filenameend## Installation.# Uses hierarchical filesystem on some systems (see initialize)#procedure install(args) write("Installing idol environment in ",env) if env ~== "" then mysystem(md||env) fout := envopen("i_object.icn","w") write(fout,"record idol_object(__state,__methods)") close(fout) fout := &null cdicont(["i_object"])end procedure makeexe(args,i) exe := args[i] if icont(lnkopt||exe) = \sysok then { mysystem("del "||exe||".icn") if \exec then { write("Executing:") exe := "iconx "||exe every i := exec+1 to *args do exe ||:= " "||args[i] mysystem(exe) } }end## system-dependent compilation of idolfile.icn# (in the idol subdirectory, if there is one)#procedure cdicont(idolfiles) if comp = -2 then return # -t --> don't icont at all args := " -c" rms := "" every ifile := !idolfiles do args ||:= " " || ifile every ifile := !idolfiles do rms ||:= " " || ifile || ".icn" every ifile := !idolfiles do mysystem("@vms "||ifile||".icn")endprocedure sysinitialize() lnkopt := " \"-Sr500\" \"-Si1000\" \"-SF30\" \"-Sg500\" " cd := "set default " md := "create/dir " env := "[.idolenv]" sysok := 1end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Object OOPS Foldewarntest.iol
# This is a test of the emergency broadcasting system.# This is only a test.class a ( field )endclass b : a ( field )end :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Object OOPS Foldeidol.doc
Programming in Idol: An Object Primer Clinton L. Jeffery March 14, 1990Idol is an object-oriented extension and environment for theIcon programming language. This document describes Idol in two parts.The first part presents Idol's object-oriented programming conceptsas an integral tool with which a programmer maps a good programdesign into a good implementation. As such, it serves asof "user's guide" for Idol's extensions to Icon. Idol'sobject-oriented programming facilities are viewed within thebroader framework of structured programming and modular designin general. Idol's precise syntax and semantics are detailed in thesecond part, "An Icon-Derived Object Language", which serves as areference manual. Object-Oriented Programming After a FashionObject-oriented programming means different things to different people.In Idol, object-oriented programming centers around encapsulation,inheritance, and polymorphism. These key ideas are shared by mostobject-oriented languages as well as many languages that are notconsidered object-oriented. This paper introduces these ideas andillustrates their use in actual code. Idol is relevant in thisdiscussion because programming concepts are more than mentalexercises; they are mathematical notations by which programmers sharetheir knowledge.Object-oriented programming can be done in Smalltalk, C++, orassembler language for that matter, but this does not mean theseprogramming notations are equally desirable. Assembler languagesare not portable. For most programmers, Smalltalk uses an aliennotation; Smalltalk programs also share the flaw that they do notwork well in environments such as UNIX and DOS that consist ofinteracting programs written in many languages. C++ has neither ofthese flaws, but the same low-level machine-oriented characterthat makes it efficient also makes C++ less than ideal as analgorithmic notation usable by nonexperts.Idol owes most of its desirable traits to its foundation, the Iconprogramming language, developed at the University of Arizona[Griswold83]. In fact, Idol presents objects simply as a toolto aid in the writing of Icon programs. Idol integrates a concise,robust notation for object-oriented programming into a languageconsiderably more advanced than C or Pascal. Icon already uses apowerful notation for expressing a general class of algorithms. Thepurpose of Idol is to enhance that notation, not to get in the way. Key ConceptsThis section describes the general concepts that Idol suppliesto authors of large Icon programs. The following section providesprogramming examples that employ these tools. The reader isencouraged to refer back to this section when clarification inthe examples section is needed.The single overriding reason for object-oriented programmingis the large program. Simple programs can be easily written inany notation. Somewhere between the 1,000-line mark and the10,000-line mark most programmers can no longer keep track of theirentire program at once. By using a very high-level programming language,less lines of code are required; a programmer can write perhaps tentimes as large a program and still be able to keep track of things.As programmers are required to write larger and larger programs,the benefit provided by very-high level languages does not keep upwith program complexity. This obstacle has been labelled the"software crisis", and object-oriented programming addresses thiscrisis. In short, the goals of object-oriented programming are toreduce the amount of coding required to write very large programs andto allow code to be understood independently of the context of thesurrounding program. The techniques employed to achieve these goalsare discussed below. EncapsulationThe primary concept advocated by object-oriented programming is theprinciple of encapsulation. Encapsulation is the isolation, in thesource code that a programmer writes, of a data representation and the codethat manipulates the data representation. In some sense, encapsulationis an assertion that no other routines in the program have "side-effects"with respect to the data structure in question. It is easier to reasonabout encapsulated data because all of the source code that could affectthat data is immediately present with its definition.Encapsulation does for data structures what the procedure does foralgorithms: it draws a line of demarcation in the program text, theoutside of which is (or can be, or ought to be) irrelevant to the inside.We call an encapsulated data structure an object. Just as a set ofnamed variables called parameters comprise the only interface between aprocedure and the code that uses it, a set of named procedures calledmethods comprise the only interface between an object and the code thatuses it.This textual definition of encapsulation as a property of programsource code accounts for the fact that good programmers can writeencapsulated data structures in any language. The problem is notcapability, but verification. In order to verify encapsulation someobject-oriented languages, like C++, define an elaborate mechanism bywhich a programmer can govern the visibility of each data structure.Like Smalltalk, Idol instead attempts to simplify verification bypreventing violations of encapsulation entirely. InheritanceIn large programs, the same or nearly the same data structures areused over and over again for a myriad of different purposes. Similarly,variations on the same algorithms are employed by structure afterstructure. In order to minimize redundancy, techniques are needed tosupport code sharing for both data structures and algorithms.Code is shared by related data structures by a programming conceptcalled inheritance.The basic premise of inheritance is simple: if I need to write codefor a new data structure which is similar to one that's alreadywritten, I can specify the new structure by giving the differencesbetween it and the old structure, instead of copying and then modifyingthe old structure's code. Obviously there are times when theinheritance mechanism is not useful: if the two data structures aremore different than they are similar, or if they are simple enoughthat inheritance would only confuse things, for example.Inheritance addresses a variety of common programming problems foundat different conceptual levels. The most obvious software engineeringproblem it solves might be termed enhancement. During thedevelopment of a program, its data structures may require extensionvia new state variables or new operations or both; inheritance isespecially useful when both the original structure and the extensionare used by the application. Inheritance also supportssimplification, or the reduction of a data structure's state variablesor operations. Simplification is analogous to argument culling afterthe fashion of the lambda calculus; it captures a logical relationbetween structures rather than a common situation in softwaredevelopment. In general, inheritance may be used in source code todescribe any sort of relational hyponymy, or special-casing; in Idolthe collection of all inheritance relations defines a directed (notnecessarily acyclic) graph. PolymorphismFrom the perspective of the writer of related data structures,inheritance provides a convenient method for code sharing, butwhat about the code that uses objects? Since objects areencapsulated, that code is not dependent upon the internals ofthe object at all, and it makes no difference to the client codewhether the object in questions belongs to the original class or theinheriting class.In fact, we can make a stronger statement. Due to encapsulation,two different executions of some code that uses objects to implementa particular algorithm may operate on different objects that arenot related by inheritance at all. Such code may effectivelybe shared by any objects that happen to implement the operationsthat the code invokes. This facility is called polymorphism, andsuch algorithms are called generic. This feature is found innon-object oriented languages; in object-oriented languages it isa natural extension of encapsulation. Object ProgrammingThe concepts introduced above are used in many programming languagesin one form or another. The following text presents these conceptsin the context of actual Idol code. This serves a dual purpose:it should clarify the object model adopted by Idol as well asprovide an initial impression of these concepts' utility in coding.In order to motivate the constructs provided by Idol, our examplebegins by contrasting conventional Icon code with Idol code whichimplements the same behavior. The semantics of the Idol code givenhere is defined by the Idol reference manual, included later in thisdocument in the section entitled, "An Icon-Derived Object Language". Before ObjectsIn order to place Idol objects in their proper context, the firstexample is taken from from regular Icon. Suppose I am writing sometext-processing application such as a text editor. Such applicationsneed to be able to process Icon structures holding the contents ofvarious text files. I might begin with a simple structure like thefollowing:record buffer(filename,text,index)where filename is a string, text is a list of stringscorresponding to lines in the file, and index is a marker forthe current line at which the buffer is being processed. Icon recorddeclarations are global; in principle, if the above declaration needsto be changed, the entire program must be rechecked. A devotee ofstructured programming would no doubt write Icon procedures to readthe buffer in from a file, write it out to a file, examine, insertand delete individual lines, etc. These procedures, along with therecord declaration given above, can be kept in a separate source file(buffer.icn) and understood independently of the program(s) inwhich they are used. Here is one such procedure:# read a buffer in from a fileprocedure read_buffer(b) f := open(b.filename) | fail b.text := [ ] b.position := 1 every put(b.text,!f) close(f) return bendThere is nothing wrong with this example; in fact its similarity to theobject-oriented example that follows demonstrates that a good, modulardesign is the primary effect encouraged by object-oriented programming.Using a separate source file to contain a record type and thoseprocedures which operate on that type allows an Icon programmer tomaintain a voluntary encapsulation of that type. After ObjectsHere is the same buffer abstraction coded in Idol. This examplelays the groundwork for some more substantial techniques to follow.class buffer(public filename,text,index) # read a buffer in from a file method read() f := open(self.filename) | fail self$erase() every put(self.text,!f) close(f) return end # write a buffer out to a file method write() f := open(self.filename,"w") | fail every write(f,!self.text) close(f) end # insert a line at the current index method insert(s) if self.index = 1 then { push(self.text,s) } else if self.index > *self.text then { put(self.text,s) } else { self.text := self.text[1:self.index]|||[s]|||self.text[self.index:0] } self.index +:= 1 return end # delete a line at the current index method delete() if self.index > *self.text then fail rv := self.text[self.index] if self.index=1 then pull(self.text) else if self.index = *self.text then pop(self.text) else self.text := self.text[1:self.index]|||self.text[self.index+1:0] return rv end # move the current index to an arbitrary line method goto(l) if (0 <= l) & (l <= self.index+1) then return self.index := l end # return the current line and advance the current index method forward() if self.index > *self.text then fail rv := self.text[self.index] self.index +:= 1 return rv end method erase() self.text := [ ] self.index := 1 endinitially if \ (self.filename) then { if not self$read() then self$erase() } else { self.filename := "*scratch*" self$erase() }endThis first example is not complex enough to illustrate the fullobject-oriented style, but its a start. Pertaining to thegeneral concepts introduced above, we can make the followinginitial observations:Polymorphism. A separate name space for each class's methodsmakes for shorter names. The same method name can be used in eachclass that implements a given operation. This notation is moreconcise than is possible with standard Icon procedures. Moreimportantly it allows algorithms to operate correctly upon objects ofany class which implements the operations required by the algorithm.Constructors. A section of code is executed automatically whenthe constructor is called, allowing initialization of fields to valuesother than &null. Of course, this could be simulated in Iconby writing a procedure that had the same effect; the value of theconstructor is that it is automatic; the programmer is freed from theresponsibility of remembering to call this code everywhere objects arecreated in the client program(s). This tighter coupling of memoryallocation and its corresponding initialization removes one moresource of program errors, especially on multiprogrammer projects.These two observations share a common theme: the net effect is thateach piece of data is made responsible for its own behavior in thesystem. Although this first example dealt with simple line-orientedtext files, the same methodology applies to more abstract entitiessuch as the components of a compiler's grammar (This exampleis taken from the Idol translator itself, which provides anotherextended example of polymorphism and inheritance.).Idol's code sharing facilities are illustrated if we extend the aboveexample. Suppose the application is more than just a text editor---it includes word-associative databases such as a dictionary,bibliography, spell-checker, thesaurus, etc. These various databasescan be represented internally using Icon tables. The table entriesfor the databases vary, but the databases all use string keywordlookup. As external data, the databases can be stored in text files,one entry per line, with the keyword at the beginning. The formatof the rest of the line varies from database to database.Although all these types of data are different, the code used toread the data files can be shared, as well as the initial constructionof the tables. In fact, since we are storing our data one entry perline in text files, we can use the code already written for buffersto do the file i/o itself.class buftable : buffer() method read() self$buffer.read() tmp := table() every line := !self.text do line ? { tmp[tab(many(&letters))] := line | fail } self.text := tmp return end method lookup(s) return self.text[s] endendThis concise example shows how little must be written to achievedata structures with vastly different behavioral characteristics,by building on code that is already written. The superclassread() operation is one important step of the subclassread() operation; this technique is common enough to have aname: it is called method combination in the literature. Itallows one to view the subclass as a transformation of thesuperclass. The buftable class is given in its
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Object OOPS Folde
+++++ Continued from previous card +++++
entirety, butour code sharing example is not complete: what about the datastructures required to support the databases themselves? They are allvariants of the buftable class, and a set of possibleimplementations is given below. Note that the formats presented aredesigned to illustrate code sharing; clearly, an actual applicationmight make different choices. BibliographiesBibliographies might consist of a keyword followed by an uninterpretedstring of information. This imposes no additional structure on thedata beyond that imposed by the buftable class. An examplekeyword would be Jeffery90.class bibliography : buftable()end Spell-checkersThe database for a spell-checker is presumably just a list of words,one per line; the minimal structure required by the buftableclass given above. Some classes exist to introduce new terminologyrather than define a new data structure. In this case we introducea lookup operation which may fail, for use in tests. In addition,since many spell-checking systems allow user definable dictionariesin addition to their central database, we allow spellCheckerobjects to chain together for the purpose of looking up words.class spellChecker : buftable(parentSpellChecker) method spell(s) return \ (self.text[s]) | (\ (self.parentSpellChecker))$spell(s) endend DictionariesDictionaries are slightly more involved. Each entry might consist of apart of speech, an etymology, and an arbitrary string of uninterpretedtext comprising a definition for that entry, separated by semicolons.Since each such entry is itself a structure, a sensible decompositionof the dictionary structure consists of two classes: one that managesthe table and external file i/o, and one that handles the manipulationof dictionary entries, including their decoding and encoding asstrings.class dictionaryentry(word,pos,etymology,definition) method decode(s) # decode a dictionary entry into its components s ? { self.word := tab(upto(';')) move(1) self.pos := tab(upto(';')) move(1) self.etymology := tab(upto(';')) move(1) self.definition := tab(0) } end method encode() # encode a dictionary entry into a string return self.word||";"||self.pos||";"||self.etymology||";"||self.definition endinitially if /self.pos then { # constructor was called with a single string argument self$decode(self.word) }endclass dictionary : buftable() method read() self$buffer.read() tmp := table() every line := !self.text do line ? { tmp[tab(many(&letters))] := dictionaryentry(line) | fail } self.text := tmp end method write() f := open(b.filename,"w") | fail every write(f,(!self.text)$encode()) close(f) endend ThesauriAlthough an oversimplification, one might conceive of a thesauri as alist of entries, each of which consists of a comma-separated list ofsynonyms followed by a comma-separated list of antonyms, with asemicolon separating the two lists. Since the code for such astructure is nearly identical to that given for dictionaries above,we omit it here (but one might reasonably capture a generalizationregarding entries organized as fields separated by semicolons). Objects and Icon Programming TecIn examining any addition to a language as large as Icon, asignificant question is how that addition relates to the rest of thelanguage. In particular, how does object-oriented programming fit intothe suite of advanced techniques used regularly by Icon programmers?Previous sections of this document expound objects as anorganizational tool, analogous but more effective than the use ofseparate compilation to achieve program modularity. Object-orientedprogramming goes considerably beyond that viewpoint.Whether viewed dynamically or statically, the primary effect achievedby object-oriented programming is the subdivision of program data inparallel with the code. Icon already provides a variety of tools thatachieve related effects:Local and Static Variables in Icon procedures are the simplestimaginable parallel association of data and code. We do not discussthem further, although they are by no means insignificant.Records allow a simple form of user-defined types. They providea useful abstraction, but keeping records associated with the rightpieces of code is still the job of the programmer.String Scanning creates scanning environments. These are veryuseful, but not very general: not all problems can be cast asstring operations.Co-expressions save a program state for later evaluation. Thispowerful facility has a sweeping range of uses, but unfortunately itis a relatively expensive mechanism that is frequently misused toachieve a simple effect.Objects and classes, if they are successful, allow a significantgeneralization of the techniques developed around the abovelanguage mechanisms. Objects do not replace these languagemechanisms, but in many cases presented below they provide anattractive alternative means of achieving similar effects. Objects and recordsObjects are simply records whose field accesses are voluntarilylimited to a certain set of procedures. Objects and scanning environmentsString scanning in Icon is another example of associating a piece ofdata with the code that operates on it. In an Icon scanningexpression of the form e1 ? e2, the result of evaluatinge1 is used implicitly in e2 via a variety of scanningfunctions. In effect, the scanning operation defines a scope in whichstate variables &subject and &pos are redefined.[Walker86] proposes an extension to Icon allowingprogrammer-defined scanning environments. The extension involves a newrecord data type augmented by sections of code to be executed uponentry, resumption, and exit of the scanning environment. The Iconscanning operator was modified to take advantage of the new facilitywhen its first argument was of the new environment data type.While objects cannot emulate Icon string scanning syntactically, theygeneralize the concept of the programmer-defined scanning environment.Classes in the Idol standard library include a wide variety ofscanning environments in addition to conventional strings. Thevariation is not limited to the type of data scanned; it also includesthe form and function of the scanning operations. The form ofscanning operations available are defined by the state variables theyaccess; in the case of Icon's built-in string scanning, a singlestring and a single integer index into that string.There is no reason that a scanning environment cannot maintain a morecomplex state, such as an input string, an output string, and a pairof indices and directions for each string. Rather than illustratethe use of objects to construct scanning environments with such anabstract model, a concrete example is presented below. List scanningList scanning is a straightforward adaptation of string scanning tothe list data type. It consists of a library class namedListScan that implements the basic scanning operations, andvarious user classes that include the scanning expressions. Thisformat is required due to Idol's inability to redefine the semanticsof the ? operator or to emulate its syntax in any reasonableway. The state maintained during a list scan consists ofSubject and Pos, analogous to &subject and&pos, respectively.ListScan defines analogies to the basic scanning functions ofIcon, e.g. tab, upto, many, any, etc. Thesefunctions are used in methods of a ListScan client class, whichin turn defines itself as a subclass of ListScan. A client such as:class PreNum : ListScan() method scan() mypos := self.Pos suspend self$tab(self$upto(numeric)) self.Pos := mypos endendmay be used in an expression such as(PreNum(["Tucson", "Pima", 15.0, [ ], "3"]))$scan()producing the result ["Tucson", "Pima"]. The conventional Iconstring scanning analogy would be: "abc123" ? tab(upto(&digits)),which produces the result "abc". Note that ListScanmethods frequently take list-element predicates as arguments wheretheir string scanning counterparts take csets. In the above example,the predicate numeric supplied to upto is an Iconfunction, but predicates may also be arbitrary user-defined procedures.The part of the Idol library ListScan class required tounderstand the previous example is presented below. This code isrepresentative of user-defined scanning classes allowing patternmatching over arbitrary data structures in Idol. Althoughuser-defined scanning is more general than Icon's built-in scanningfacilities, the scanning methods given below are alwaysactivated in the context of a specific environment. Icon stringscanning functions can be supplied an explicit environment usingadditional arguments to the function.class ListScan(Subject,Pos) method tab(i) if i<0 then i := *self.Subject+1-i if i<0 | i>*self.Subject+1 then fail origPos := self.Pos self.Pos := i suspend self.Subject[origPos:i] self.Pos := origPos end method upto(predicate) origPos := self.Pos every i := self.Pos to *(self.Subject) do { if predicate(self.Subject[i]) then suspend i } self.Pos := origPos endinitially /(self.Subject) := [ ] /(self.Pos) := 1end Objects and co-expressionsObjects cannot come close to providing the power of co-expressions,but they do provide a more efficient means of achieving well-knowncomputations such as parallel expression evaluation that have beenpromoted as uses for co-expressions. In particular, a co-expressionis able to capture implicitly the state of a generator for laterevaluation; the programmer is saved the trouble of explicitly codingwhat can be internally and automatically performed by Icon'sexpression mechanism. While objects cannot capture a generator stateimplicitly, the use of library objects mitigates the cost ofexplicitly encoding the computation to be performed, as analternative to the use of co-expressions. The use of objects also isa significant alternative for implementations of Icon in whichco-expressions are not available or memory is limited. Parallel evaluationIn [Griswold87], co-expressions are used to obtain the resultsfrom several generators in parallel:decimal := create(0 to 255)hex := create(!"0123456789ABCDEF" || !"0123456789ABCDEF")octal := create((0 to 3) || (0 to 7) || (0 to 7))character := create(image(!&cset))while write(right(@decimal,3)," ",@hex," ",@octal," ",@character)For the Idol programmer, one alternative to using co-expressions wouldbe to link in the following code from the Idol standard library:procedure sequence(bounds[ ]) return Sequence(bounds)endclass Sequence(bounds,indices) method max(i) elem := self.bounds[i] return (type(elem)== "integer",elem) | *elem-1 end method elem(i) elem := self.bounds[i] return (type(elem)== "integer",self.indices[i]) | elem[self.indices[i]+1] end method activate() top := *(self.indices) if self.indices[1] > self$max(1) then fail s := "" every i := 1 to top do { s ||:= self$elem(i) } repeat { self.indices[top] +:= 1 if top=1 | (self.indices[top] <= self$max(top)) then break self.indices[top] := 0 top -:= 1 } return s endinitially / (self.indices) := list(*self.bounds,0)endOn the one hand, the above library code is neither terse nor generalcompared with co-expressions. This class does, however, allow theparallel evaluation problem described previously to be coded as:decimal := sequence(255)hex := sequence("0123456789ABCDEF","0123456789ABCDEF")octal := sequence(3,7,7)character := sequence(string(&cset))while write(right($@decimal,3)," ",$@hex," ",$@octal," ",image($@character))$@ is the unary Idol meta-operator that invokes theactivate() operation. Since the sequence class is alreadywritten and available, its use is an attractive alternative toco-expressions in many settings. For example, a general class oflabel generators (another use of co-expressions cited in[Griswold87]) is defined by the following library class:class labelgen : Sequence(prefix,postfix) method activate() return self.prefix||self$Sequence.activate()||self.postfix endinitially /(self.prefix) := "" /(self.postfix) := "" /(self.bounds) := [50000]endAfter creation of a label generator object (e.g.label := labelgen("L",":")), each resulting label is obtainedvia $@label. The sequence defined by this example is L0: L1: ... L50000: ConclusionIdol presents object programming as a collection of tools to reducethe complexity of large Icon programs. These tools are encapsulation,inheritance, and polymorphism. Since a primary goal of Idol is topromote code sharing and reuse, a variety of specific programmingproblems have elegant solutions available in the Idol class library. An Icon-Derived Object LanguageThis section serves as the language reference manual for Idol. Idolis a preprocessor for Icon which implements a means of associating apiece of data with the procedures which manipulate it. The primarybenefits to the programmer are thus organizational. The Iconprogrammer may view Idol as providing an augmented record type inwhich field accesses are made not directly on the records' fields, butrather through a set of procedures associated with the type. ClassesSince Idol implements ideas found commonly in object-orientedprogramming languages, its terminology is taken from that domain. Theaugmented record type is called a "class". The syntax of a class is:class foo(field1,field2,field3,...) # procedures to access # class foo objects[code to initialize class foo objects]endIn order to emphasize the difference between ordinary Icon proceduresand the procedures which manipulate class objects, these proceduresare called "methods" (the term is again borrowed from theobject-oriented community). Nevertheless, the syntax of a method isthat of a procedure:method bar(param1,param2,param3,...) # Icon code which may access # fields of a class foo objectendSince execution of a class method is always associated with a givenobject of that class, the method has access to an implicit variablecalled self which is a record containing fields whose names arethose given in the class declaration. References to the self variablelook just like normal record references; they use the dot (.)operator. In addition to methods, classes may also contain regularIcon procedure, global, and record declarations; such declarationshave the standard semantics and exist in the global Icon name space. ObjectsLike records, instances of a class type are created with a constructorfunction whose name is that of the class. Instances of a class arecalled objects, and their fields may be initialized explicitly in theconstructor in exactly the same way as for records. For example,after defining a class foo(x,y) one may write:procedure main() f := foo(1,2)endThe fields of an object need not be initialized by the classconstructor. For many objects it is more logical to initialize theirfields to some standard value. In this case, the class declarationmay include an "initially" section after its methods are defined andb
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Object OOPS Folde
+++++ Continued from previous card +++++
efore its end.This section begins with a line containing the word "initially" andthen contains lines which are executed whenever an object of thatclass is constructed. These lines may reference and assign to theclass fields as if they were normal record fields for the object beingconstructed. The "record" being constructed is named self;more on self later.For example, suppose one wished to implement an enhanced table typewhich permitted sequential access to elements in the order they wereinserted into the table. This can be implemented by a combination ofa list and a table, both of which would initialized to the appropriateempty structure:class taque(l,t) # pronouned `taco' # methods to manipulate taques, # e.g. insert, lookup, foreach...initially self.l := [ ] self.t := table()endAnd in such a case one can create objects without including argumentsto the class constructor:procedure main() mytaque := taque()endIn the absence of an initially section, missing arguments to aconstructor default to the null value. Together with an initiallysection, the class declaration looks rather like a procedure thatconstructs objects of that class. Note that one may write classeswith some fields that are initialized explicitly by the constructorand other fields are initialized automatically in the initiallysection. In this case one must either declare the automaticallyinitialized fields after those that are initialized in theconstructor, or insert &null in the positions of theautomatically initialized fields in the constructor. Object InvocationOnce one has created an object with a class constructor, onemanipulates the object by invoking methods defined by its class.Since objects are both procedures and data, object invocation issimilar to both a procedure call and a record access. The dollar($) operator invokes one of an object's methods. It usedsimilarly to the dot (.) operator used to access record fields.Using the taque example:procedure main() mytaque := taque() mytaque$insert("greetings","hello") mytaque$insert(123) every write(mytaque$foreach()) if \(mytaque$lookup("hello")) then write(", world")endNote that direct access to an object's fields using the usual dot (.)operator is not possible outside of a method of the appropriate class.Attempts to reference mystack.l in procedure main() would result ina runtime error (invalid field name). Within a class method, theimplicit variable self allows access to the object's fields inthe usual manner. The taque insert method is thus: method insert(x,key) /key := x put(self.l,x) self.t[key] := x endThe self variable is both a record and an object. It allows fieldaccess just like a record, as well as method invocation like any otherobject. Thus class methods can use self to invoke other class methodswithout any special syntax. InheritanceIn many cases, two classes of objects are very similar. Inparticular, many classes can be thought of simply as enhancements ofsome class that has already been defined. Enhancements might take theform of added fields, added methods, or both. In other cases a classis just a special case of another class. For example, if one haddefined a class fraction(numerator, denominator), one might want todefine a class inverses(denominator) whose behavior was identical tothat of a fraction, but whose numerator was always 1.Idol supports both of these ideas with the concept of inheritance.When the definition of a class is best expressed in terms of thedefinition of another class or classes, we call that class a subclassof the other classes. This corresponds to the logical relation ofhyponymy. It means an object of the subclass can be manipulated justas if it were an object of one of its defining classes. In practicalterms it means that similar objects can share the code thatmanipulates their fields. The syntax of a subclass isclass foo : superclasses (fields...)# methods[optional initially section]end Multiple InheritanceThere are times when a new class might best be described as acombination of two or more classes. Idol classes may have more thanone superclass, separated by colons in the class declaration. This iscalled multiple inheritance.Subclasses define a record type consisting of all the fieldnames foundin the class itself and in all its superclasses. The subclass hasassociated methods consisting of those in its own body, those in thefirst superclass which were not defined in the subclass, those in thesecond superclass not defined in the subclass or the first superclass,and so on. Fields are initialized either by the constructor or by theinitially section of the first class of the class:superclass list inwhich the field is defined. For example, to define a class ofinverses in terms of a class fraction(numerator,denominator) onewould write:class inverse : fraction (denominator)initially self.numerator := 1endObjects of class inverse can be manipulated using all the methodsdefined in class fraction; the code is actually shared by both classesat runtime.Viewing inheritance as the addition of fieldnames and methods ofsuperclasses not already defined in the subclass is the opposite ofthe more traditional object-oriented view that a subclass starts withan instance of the superclass and augments or overrides portions ofthe definition with code in the subclass body. Idol's viewpoint addsquite a bit of leverage, such as the ability to define classes whichare subclasses of each other. This feature is described further below. Invoking Superclass OperationsWhen a subclass defines a method of the same name as a method definedin the superclass, invocations on subclass objects always result inthe subclass' version of the method. This can be overridden byexplicitly including the superclass name in the invocation:object$superclass.method(parameters)This facility allows the subclass method to do any additional workrequired for added fields before or after calling an appropriatesuperclass method to achieve inherited behavior. The result isfrequently a chain of inherited method invocations. Public FieldsAs noted above, there is a strong correspondence between records andclasses. Both define new types which extend Icon's built inrepertoire. For simple jobs, records are slightly faster as well asmore convenient: the user can directly read and write a record'sfields by name.Classes, on the other hand, promote the re-use of code and reduce thecomplexity required to understand or maintain large, involvedstructures. They should be used especially when manipulatingcomposite structures ontaining mixes of structures as elements, e.g.lists containing tables, sets, and lists in various positions.Sometimes it would be really nice to access fields in an objectdirectly, as with records. An example from the Idol program itself isthe name field associated with methods and classes---it is astring which is intended to be read outside the object. One canalways implement a method which returns (or assigns, for that matter)a field value, but this gets tedious. Idol currently supportsread-only access to fields via the public keyword. Ifpublic precedes a fieldname in a class declaration, Idolautomatically generates a method of the same name which dereferencesand returns the field. For example, the declarationclass sinner(pharisee,public publican)generates code equivalent to the following class method in additionto any explicitly defined methods: method publican() return .(self.publican) endThis feature, despite its utility and the best of intentions, makes itpossible to subvert object encapsulation: it should not beused with fields whose values are structures, since the structurecould then be modified from the outside. When invoked with the-strict option, Idol generates code for public methods whichchecks for a scalar type at runtime before returning the field. Superclass Cycles and Type EquivalenceIn many situations, there are several ways to represent the sameabstract type. Two-dimensional points might be represented byCartesian coordinates x and y, or equivalently by radial coordinatesexpressed as degree d and radian r. If one were implementing classescorresponding to these types there is no reason why one of them shouldbe considered a subclass of the other. The types are trulyinterchangeable and equivalent.In Idol, expressing thisequivalence is simple and direct. In defining classes Cartesianand Radian we may declare them to be superclasses of each other:class Cartesian : Radian (x,y)# code which manipulates objects using cartesian coordinatesendclass Radian : Cartesian (d,r)# code which manipulates objects using radian coordinatesendThese superclass declarations make the two types equivalent names forthe same type of object; after inheritance, instances of both classeswill have fields x,y,d, and r, and support the same set of operations.Equivalent types each have their own constructor given by their classname; although they export the same set of operations, the actualprocedures invoked by the different instances may be different. Forexample, if both classes define an implementation of a methodprint, the method invoked by a given instance depends onwhich constructor was used when the object was created.If a class inherits any methods from one of its equivalentclasses, it is responsible for initializing the state of allthe fields used by those methods in its own constructor, andmaintaining the state of the inherited fields when its methods makestate changes to its own fields. In the geometric example givenabove, in order for class Radian to use any methods inheritedfrom class Cartesian, it must at least initialize x and y explicityin its constructor from calculations on its d and r parameters.In general, this added responsibility is minimized in those classeswhich treat an object's state as a value rather than a structure.The utility of equivalent types expressed by superclass cycles remainsto be seen. At the least, they provide a convenient way to writeseveral alternative constructors for the same class of objects.Perhaps more importantly, their presence in Idol causes us to questionthe almost religious dogmatism that the superclass graph must alwaysbe acyclic. MiscellanyIdol supports some shorthand for convenient object invocation. Inparticular, if a class defines methods named size, foreach, random,or activate, these methods can be invoked by a modified version ofthe usual Icon operator:$*x is equivalent to x$size()$?x is equivalent to x$random()$!x is equivalent to x$foreach()$@x is equivalent to x$activate()Other operators may be added to this list. If x is an identifierit may be used directly; if it is a more complex expression (such as afunction call) it should be parenthesized, e.g.$*(complex_expression()).Parentheses are also required in the case of invoking an objectreturned from an invocation, e.g. (classes$lookup("theClass"))$name()These requirements are artifacts of the first implementation and aresubject to change.The Idol preprocessor is written in Idol and does not actually parsethe language it purports to implement. In particular, thepreprocessor is line-oriented and class and method declarations, theinitially keyword, and the class and method end keyword need to be ona line by themselves. Similarly, both the object being invoked andits method and parameters must be on the same line for invocations.The Idol preprocessor reserves certain names for internal use. Inparticular, __state and __methods are not legal classfield names. Similarly, the name idol_object is reserved in theglobal name space, and may not be used as a global variable, procedure,or record name. Finally, for each class foo amongst the user'scode, the names foo, foo___state, foo___methods,foo__oprec are reserved, as are the names foo__barcorresponding to each method bar in class foo. Thesedetails are artifacts of the current implementation and are subjectto change.Subclass constructors can be confusing, especially when multipleinheritance brings in various fields from different superclasses.One significant problem for users of the subclass is that theparameters expected in the constructor may not be obvious if theyare inherited from a superclass. On the other side of the spectrum,superclasses which automatically initialize their fields can beless than useful if the subclass might need to override thedefault initialization value--the subclass must then explicitlyname the field in order to make its initially section haveprecedence over the superclass.The first of the two problems given above can be solved by namingfields explicitly in a subclass when initialization by constructor.This achieves clarity at the expense of changing the inheritancebehavior, since the subclass no longer inherits the superclassautomatic initialization for that field if there is one. The f the two problems can generally be solved by using the / operatorin automatic field initializations unless the initialization shouldnever be overridden.While it is occasionally convenient to redeclare an inherited fieldin a subclass, accidentally doing so and then using that field to store anunrelated value would be disastrous. Although Idol offers no propersolution to this problem, the -strict option causes the generationof warning messages for each redefined field name noting the relevantsub- and superclasses. Running IdolIdol requires Version 7.5 or higher of Icon. It runs best on UNIXsystems. It has not been ported to all the various micros andoperating systems on which Icon 7.5 runs. In particular, if yourversion of Icon does not support the system() function, or yourmachine does not have adequate memory available, Idol will not beable to invoke icont to complete its translation and linking.Since Idol is untested on many systems, you may have to make smallchanges to the source code in order to port it to a new system. Getting a CopyIdol is in the public domain. It is available on the Icon BBS and byanonymous ftp from cs.arizona.edu. Idol is also distributed withthe program library for Version 8 of Icon and is available by mail inthis way. Interested parties may contact the author(cjeffery@cs.arizona.edu): Department of Computer Science University of Arizona Tucson, AZ 85721 Creating an Idol executableIdol is typically distributed in both Idol and Icon source forms.Creating an Idol executable requires a running version of Icon and acopy of idolboot.icn, the Icon source for Idol. A second Iconsource file contains the operating-system dependent portion of Idol;for example, unix.icn (see the Idol README file for the name ofyour system file if you are not on a UNIX system; you may have towrite your own, but it is not difficult). Using icont, compileidolboot.icn and unix.icn into an executable file (namedidolboot, or idolboot.icx). As a final step, rename thisexecutable to idol (or idol.icx). Installing the Idol Library MechanismFor each directory in which Idol source is kept, the Idol preprocessornormally uses a subdirectory to store its generated code on systemswhich support a hierarchical file system. On systems without ahierarchy, it stores generated code in the sou
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Object OOPS Folde
+++++ Continued from previous card +++++
rce directory. Beforeactually running Idol on any source files you should install theIdol libraries. This is done by invoking the commandidol -install(some systems use "iconx idol -install"). Follow anydirections given at this point; on most systems installation isentirely automatic. Translating Idol ProgramsThe syntax for invoking idol is normallyidol file1[.iol] [files...](on some systems you may have to say "iconx idol" where itsays "idol" above). The Idol translator creates a separateIcon file for each class in the Idol source files you give it. Onmost systems it calls icont automatically to create ucode for thesefiles. If the first file on the command line has any normal Icon codein it (in addition to any class definitions it may contain), Idolattempts to link it to any classes it may need and create an executable.The file extension defaults to .iol. Idol also acceptsextensions .icn, .u1, and .cl. The first two referto Icon source or already translated code for which Idol generateslink statements in the main (initial) Idol source file. Idol treatsarguments with the extension .cl as class names and generateslink statements for that class and its superclasses. References[Gris83]Griswold, R.E. and Griswold, M.T.The Icon Programming Language.Prentice-Hall, Englewood Cliffs, New Jersey, 1983.[Gris87]Griswold, R.E.Programming in Icon; Part I---Programming with Co-Expressions.Technical Report 87-6, Department of Computer Science, University of Arizona, June 1987.[Walk86]Walker, K.Dynamic Environments---A Generalization of Icon String Scanning.Technical Report 86-7, Department of Computer Science, University of Arizona, March 1986. :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Object OOPS Foldeidol.man
NAME idol - Icon-Derived Object LanguageSYNOPSIS idol -install idol [ option ... ] mainfile otherfiles... [-x arguments]DESCRIPTION Idol is an object-oriented preprocessor for Version 7.5+ Icon. It is a front-end for icont(1); typically one invokes idol on a source file (extension .iol) which is translated into an Icon source file (extension .icn) which is translated into a file suitable for interpretation by the Icon interpreter. Each directory containing Idol source files should be initialized by "idol -install" prior to translating any user sources. Producing an executable is skipped when the first file on the list contains only classes. The following options are recognized by idol: -c Suppress the linking phase -t Suppress all translation by icont -s Suppress removal of .icn files after translation by icont -quiet Suppress most Idol-specific console messages -install Install the Idol environment in the current directory -strict Generate code which is paranoid about ensuring encapsulation -version Print out the version of Idol and its date of creation The second and following files on the command line may include extensions .icn, .u1, and .cl. The first two Idol treats as Icon source code which should be translated and linked into the resulting executable. Files with extension .cl are treated as class names which are linked into the resulting executable. If no extension is given, Idol attempts to find the desired source file by appending .iol, .icn, .u1, or .cl in that order.FILES ./prog.iol : source file ./prog.icn : code generated for non-classes in prog.iol ./idolcode.env/i_object.* : Icon code for the universal object type ./idolcode.env/classname.icn : Icon files are generated for each class ./idolcode.env/classname.u[12] : translated class files ./idolcode.env/classname : class specification/interfaceSEE ALSO "Programming in Idol: An Object Primer" (U of Arizona Dept of CS Technical Report #90-10) serves as user's guide and reference manual for Idol :MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Object OOPS Foldeidolboot.icn
global fin,fout,fName,fLine,alpha,alphadot,white,nonwhite,nonalphaglobal classes,comp,exec,strict,links,imports,loud,compilesprocedure initialize()#line 47 "idol.iol" loud := 1 comp := 0 alpha := &ucase ++ &lcase ++ '_' ++ &digits nonalpha := &cset -- alpha alphadot := alpha ++ '.' white := ' \t\014' nonwhite := &cset -- white classes := taque() links := [] imports := [] compiles := [] sysinitialize()endprocedure main(args)#line 62 "idol.iol" initialize() if *args = 0 then write("usage: idol files...") else { every i := 1 to *args do { if \exec then next if args[i][1] == "-" then { case map(args[i]) of { "-c" : { sysok := &null if comp = 0 then comp := -1 } "-install": return install(args[1:i+1]) "-quiet" : loud := &null "-strict" : strict := 1 "-s" : sysok := &null "-t" : comp := -2 "-version": return write("Idol version 6.30 of 3/14/90") & 0 "-x" : exec := i } } else if args[i][find(".cl",args[i]):0] := "" then push(imports,args[i]) else if args[i][find(".icn",args[i]):0] := "" then { push(links,args[i]) icont(" -c "||args[i]) } else if args[i][find(".u1",args[i]):0] := "" then push(links,args[i]) else if (args[i][find(".iol",args[i]):0] := "") | tryopen(args[i]||".iol","r") then { /exe := i args[i][find(".iol",args[i]):0] := "" /fout := sysopen(args[i]||".icn","w") readinput(args[i]||".iol",1) } else { if tryopen(args[i]||".icn","r") then { push(links,args[i]) icont(" -c "||args[i]) } else if tryopen(args[i]||".u1") then push(links,args[i]) else if tryenvopen(args[i]) then push(imports,args[i]) } } gencode() close(\fout) if comp = 1 then makeexe(args,exe) }endprocedure gencode()#line 118 "idol.iol" if \loud then write("Class import/export:") every cl := (__self1 := classes).__methods.foreach_t(__self1.__state) do (__self2 := cl).__methods.writespec(__self2.__state) repeat { added := 0 every super:= ((__self2 := ((__self1 := classes).__methods.foreach_t(__self1.__state))).__methods.foreachsuper(__self2.__state) | !imports) do{ if /(__self1 := classes).__methods.lookup(__self1.__state,super) then { added := 1 fname := filename(super) readinput(envpath(fname),2) if /(__self1 := classes).__methods.lookup(__self1.__state,super) then halt("can't import class '",super,"'") writesublink(fname) } } if added = 0 then break } every (__self2 := ((__self1 := classes).__methods.foreach_t(__self1.__state))).__methods.transitive_closure(__self2.__state) if \loud then write("Generating code:") writesublink("i_object") every s := !links do writelink(s) write(fout) every out := (__self1 := classes).__methods.foreach(__self1.__state) do { name := filename((__self1 := out).__methods.name(__self1.__state)) (__self1 := out).__methods.write(__self1.__state) put(compiles,name) writesublink(name) } if *compiles>0 then cdicont(compiles)endprocedure notquote(s)#line 713 "idol.iol" quotes := 0 outs := "" s ? { while outs ||:= tab(find("\\")+1) do { move(1) } outs ||:= tab(0) } s := outs outs := "" s ? { while outs ||:= tab(find("\""|"'")+1) do { quotes +:= 1 if tab(find(outs[-1])) then { quotes +:= 1 move(1) } } } if quotes % 2 = 0 then returnendprocedure readln()#line 739 "idol.iol" count := 0 if line := read(fin) then { fLine +:= 1 line[ 1(x<-find("#",line),notquote(line[1:x])) : 0] := "" line := trim(line) while ((x := find("$",line)) & notquote(line[1:x])) do { z := line[x+1:0] ||" " if find(line[x+1],"!*@?") then { z ? { move(1) tab(many(white)) if not (id := tab(many(alphadot))) then { if not match("(") then halt("readline can't parse ",line) if not (id := tab(&pos<bal())) then halt("readline: cant bal ",&subject) } case line[x+1] of { "@": Op := "activate" "*": Op := "size" "!": Op := "foreach" "?": Op := "random" default: halt("readline: unknown operator $",line[x+1]) } count +:= 1 line[x:0] := "(__self"||count||" := "||id||").__methods."|| Op||"(__self"||count||".__state)"||tab(0) } } else { reverse(line[1:x])||" " ? { tab(many(white)) if not (id := reverse(tab(many(alphadot)))) then { if not match(")") then halt("readline: can't parse") if not (id := reverse(tab(&pos<bal(&cset,')','(')))) then halt("readline: can't bal ",&subject) } nummatched := &pos-1 } if not (lp := find("(",z)) then halt("readline: expected '('") if z[lp+1] ~== ")" then c:="," else c:="" count +:= 1 line[x-nummatched : x+lp+1] := "(__self"||count||" := "||id||").__methods."|| z[1:lp+1]||"__self"||count||".__state"||c } } return line } else failendprocedure readinput(name,phase)#line 795 "idol.iol" if \loud then write("\t",name) fName := name fLine := 0 fin := sysopen(name,"r") while line := readln() do { line ? { tab(many(white)) if ="class" then { decl := class() (__self1 := decl).__methods.read(__self1.__state,line,phase) if phase=1 then { (__self1 := decl).__methods.writemethods(__self1.__state) (__self1 := classes).__methods.insert(__self1.__state,decl,(__self2 := decl).__methods.name(__self2.__state)) } else (__self1 := classes).__methods.insert_t(__self1.__state,decl,(__self2 := decl).__methods.name(__self2.__state)) } else if ="procedure" then { if comp = 0 then comp := 1 decl := method("") (__self1 := decl).__methods.read(__self1.__state,line,phase) (__self1 := decl).__methods.write(__self1.__state,fout,"") } else if ="record" then { if comp = 0 then comp := 1 decl := declaration(line) (__self1 := decl).__methods.write(__self1.__state,fout,"") } else if ="global" then { if comp = 0 then comp := 1 decl := Global(line) (__self1 := decl).__methods.write(__self1.__state,fout,"") } else if ="method" then { halt("readinput: method outside class") } } } close(fin)endprocedure halt(args[])#line 838 "idol.iol" errsrc() every writes(&errout,!args) stop()endprocedure warn(args[])#line 844 "idol.iol" errsrc() every writes(&errout,!args) write(&errout)endprocedure errsrc()#line 850 "idol.iol" writes(&errout,"\"",\fName,"\", line ",\fLine,": Idol/")endprocedure tryopen(file,mode)#line 856 "idol.iol" if f := open(file,mode) then return close(f)endprocedure tryenvopen(file,mode)#line 859 "idol.iol" return tryopen(envpath(file),mode)endprocedure sysopen(file,mode)#line 862 "idol.iol" if not (f := open(file,mode)) then halt("Couldn't open file ",file," for mode ",mode) return fendprocedure envopen(file,mode)#line 867 "idol.iol" return sysopen(envpath(file),mode)endprocedure writelink(s)#line 870 "idol.iol" write(fout,"link \"",s,"\"")endprocedure icont(argstr,prefix)#line 873 "idol.iol"static sinitial { s := (getenv("ICONT")|"icont") } return mysystem(\prefix||s||argstr | s||argstr)endrecord idol_object(__state,__methods)procedure declarationread(self,decl)#line 169 "idol.iol" decl ? { tab(many(white)) if not (self.tag := =("procedure"|"class"|"method"|"record")) then halt("declaration/read can't parse decl ",decl) tab(many(white)) if not (self.name := tab(many(alpha))) then halt("declaration/read can't parse decl ",decl) if not tab(find("(")+1) then halt("declaration/read can't parse decl ",decl) tab(many(white)) self.fields := classFields() if not ((__self1 := self.fields).__methods.parse(__self1.__state,tab(find(")")))) then halt("declaration/read can't parse decl ",decl) } endprocedure declarationwrite(self,f)#line 192 "idol.iol" write(f,(__self1 := self).__methods.String(__self1.__state)) endprocedure declarationString(self)#line 198 "idol.iol" return self.tag || " " || self.name || "(" || (__self1 := self.fields).__methods.String(__self1.__state) || ")" endrecord declaration_state(__state,__methods,name,fields,tag)record declaration_methods(read,write,String,name)global declaration__oprecprocedure declaration(name,fields,tag)local self,cloneinitial { if /declaration__oprec then declarationinitialize() } self := declaration_state(&null,declaration__oprec,name,fields,tag) self.__state := self declarationinitially(self) return idol_object(self,declaration__oprec)endprocedure declarationinitialize() initial declaration__oprec := declaration_methods(declarationread,declarationwrite,declarationString,declarationname)endprocedure declarationinitially(self)#line 201 "idol.iol" if \self.name then (__self1 := self).__methods.read(__self1.__state,self.name)endprocedure declarationname(self) return .(self.name)endprocedure bodyread(self)#line 210 "idol.iol" self.fn := fName self.ln := fLine self.text := [] while line := readln() do { put(self.text, line) line ? { tab(many(white)); if ="end" & &pos > *line then return } } halt("body/read: eof inside a procedure/method definition") endprocedure bodywrite(self,f)#line 220 "idol.iol" if \self.ln then write(f,"#line ",self.ln," \"",self.fn,"\"") every write(f,(__self1 := self).__methods.foreach(__self1.__state)) endprocedure bodydelete(self)#line 224 "idol.iol" return pull(self.text) endprocedure bodysize(self)#line 227 "idol.iol" return (*\ (self.text)) | 0 endprocedure bodyforeach(self)#line 230 "idol.iol" if t := \self.text then suspend !self.text endrecord body_state(__state,__methods,fn,ln,text)record body_methods(read,write,delete,size,foreach)global body__oprecprocedure body(fn,ln,text)local self,cloneinitial { if /body__oprec then bodyinitialize() } self := body_state(&null,body__oprec,fn,ln,text) self.__state := self return idol_object(self,body__oprec)endprocedure bodyinitialize() initial body__oprec := body_methods(bodyread,bodywrite,bodydelete,bodysize,bodyforeach)endprocedure classread(self,line,phase)#line 242 "idol.iol" (__self1 := self).__methods.declaration.read(__self1.__state,line) self.supers := idTaque(":") (__self1 := self.supers).__methods.parse(__self1.__state,line[find(":",line)+1:find("(",line)] | "") self.methods:= taque() self.text := body() while line := readln() do { line ? { tab(many(white)) if ="initially" then { (__self1 := self.text).__methods.read(__self1.__state) if phase=2 then return (__self1 := self.text).__methods.delete(__self1.__state) return } else if ="method" then { decl := method(self.name) (__self1 := decl).__methods.read(__self1.__state,line,phase) (__self1 := self.methods).__methods.insert(__self1.__state,decl,(__self2 := decl).__methods.name(__self2.__state)) } else if ="end" then { return } else if ="procedure" then { decl := Procedure("") (__self1 := decl).__methods.read(__self1.__state,line,phase) /self.glob := [] put(self.glob,decl) } else if ="global" then { /self.glob := [] put(self.glob,Global(line)) } else if ="record" then { /self.glob := [] put(self.glob,declaration(line)) } else if upto(nonwhite) then { halt("class/read expected declaration on: ",line) } } } halt("class/read syntax error: eof inside a class definition") endprocedure classhas_initially(self)#line 286 "idol.iol" return (__self1 := self.text).__methods.size(__self1.__state) > 0 endprocedure classispublic(self,fieldname)#line 289 "idol.iol" if (__self1 := self.fields).__methods.ispublic(__self1.__state,fieldname) then return fieldname endprocedure classforeachmethod(self)#line 292 "idol.iol" suspend (__self1 := self.methods).__methods.foreach(__self1.__state) endprocedure classforeachsuper(self)#line 295 "idol.iol" suspend (__self1 := self.supers).__methods.foreach(__self1.__state) endprocedure classforeachfield(self)#line 298 "idol.iol" suspend (__self1 := self.fields).__methods.foreach(__self1.__state) endprocedure classtransitive_closure(self)#line 301 "idol.iol" count := (__self1 := self.supers).__methods.size(__self1.__state) while count > 0 do { added := taque() every sc := (__self1 := self.supers).__methods.foreach(__self1.__state) do { if /(super := (__self1 := classes).__methods.lookup(__self1.__state,sc)) then halt("class/transitive_closure: couldn't find superclass ",sc) every supersuper := (__self1 := super).__methods.foreachsuper(__self1.__state) do { if / (__self1 := self.supers).__methods.lookup(__self1.__state,supersuper) & /(__self1 := added).__methods.lookup(__self1.__state,supersuper) then { (__self1 := added).__methods.insert(__self1.__state,supersuper) } } } count := (__self1 := added).__methods.size(__self1.__state) every (__self1 := self.supers).__methods.insert(__self1.__state,(__self2 := added).__methods.foreach(__self2.__state)) } endprocedure classwritedecl(self,f,s)#line 323 "idol.iol" writes(f, s," ",self.name) if s=="class" & ( *(supers := (__self1 := self.supers).__methods.String(__self1.__state)) > 0 ) then writes(f," : ",supers) writes(f,"(") rv := (__self1 := self.fields).__methods.String(__self1.__state,s) if *rv > 0 then rv ||:= "," if s~=="class" & \self.ifields then every l := !self.ifields do rv ||:= l.ident || "," writes(f,rv[1:-1]) write(f,,")") endprocedure classwritespec(self,f)#line 335 "idol.iol" f := envopen(filename(self.name),"w") (__self1 := self).__methods.writedecl(__self1.__state,f,"class") every (__self2 := ((__self1 := self.methods).__methods.foreach(__self1.__state))).__methods.writedecl(__self2.__state,f,"method") if (__self1 := self).__methods.has_initially(__self1.__state) then write(f,"initially") write(f,"end") close(f) endprocedure classwritemethods(self)#line 348 "idol.iol" f:= envopen(filename(self.name)||".icn","w") every (__self2 := ((__self1 := self.methods).__methods.foreach(__self1.__state))).__methods.write(__self2.__state,f,self.name) if \self.glob & *self.glob>0 then { write(f,"#\n# globals declared within the class\n#") every i := 1 to *self.glob do (__self1 := (self.glob[i])).__methods.write(__self1.__state,f,"") } close(f) endprocedure classwrite(self)#line 362 "idol.iol" f:= envopen(filename(self.name)||".icn","a") if /self.ifields then (__self1 := self).__methods.resolve(__self1.__state) writes(f,"record ",self.name,"_state(__state,__methods") rv := "," rv ||:= (__self1 := self.fields).__methods.idTaque.String(__self1.__state) if rv[-1] ~== "," then rv ||:= "," every s := (!self.ifields).ident do rv ||:= s || "," write(f,rv[1:-1],")") writes(f,"record ",self.name,"_methods(") rv := "" every s := (((__self2 := ((__self1 := self.methods).__methods.foreach(__self1.__state))).__methods.name(__self2.__state)) | (__self1 := self.fields).__methods.foreachpublic(__self1.__state) | (!self.imethods).ident | (__self1 := self.supers).__methods.foreach(__self1.__state)) do rv ||:= s || "," if *rv>0 then rv[-1] := "" write(f,rv,")") writes(f,"global ",self.name,"__oprec") every writes(f,", ", (__self1 := self.supers).__methods.foreach(__self1.__state),"__oprec") write(f) (__self1 := self).__methods.writedecl(__self1.__state,f,"procedure") write(f,"local self,clone") write(f,"initial {\n", " if /",self.name,"__oprec then ",self.name,"initialize()") if (__self1 := self.supe
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:ICON V8.0:Icon V8.0 Object OOPS Folde
+++++ Continued from previous card +++++
rs).__methods.size(__self1.__state) > 0 then every (super <- (__self1 := self.supers).__methods.foreach(__self1.__state)) ~== self.name do write(f," if /",super,"__oprec then ",super,"initialize()\n", " ",self.name,"__oprec.",super," := ", super,"__oprec") write(f," }") writes(f," self := ",self.name,"_state(&null,",self.name,"__oprec") every writes(f,",",(__self1 := self.fields).__methods.foreach(__self1.__state)) if \self.ifields then every writes(f,",",(!self.ifields).ident) write(f,")\n self.__state := self") if (__self1 := self.text).__methods.size(__self1.__state) > 0 then write(f," ",self.name,"initially(self)") if (__self1 := self.supers).__methods.size(__self1.__state) > 0 then { every (super <- (__self1 := self.supers).__methods.foreach(__self1.__state)) ~== self.name do { if (__self2 := ((__self1 := classes).__methods.lookup(__self1.__state,super))).__methods.has_initially(__self2.__state) then { if /madeclone := 1 then { write(f," clone := ",self.name,"_state()\n", " clone.__state := clone\n", " clone.__methods := ",self.name,"__oprec") } write(f," # inherited initialization from class ",super) write(f," every i := 2 to *self do clone[i] := self[i]\n", " ",super,"initially(clone)") every l := !self.ifields do { if l.class == super then write(f," self.",l.ident," := clone.",l.ident) } } } } write(f," return idol_object(self,",self.name,"__oprec)\n", "end\n") write(f,"procedure ",self.name,"initialize()") writes(f," initial ",self.name,"__oprec := ",self.name,"_methods") rv := "(" every s := (__self2 := ((__self1 := self.methods).__methods.foreach(__self1.__state))).__methods.name(__self2.__state) do { if *rv>1 then rv ||:= "," rv ||:= self.name||s } every me := (__self1 := self.fields).__methods.foreachpublic(__self1.__state) do { if *rv>1 then rv ||:= "," rv ||:= self.name||me } every l := !self.imethods do { if *rv>1 then rv ||:= "," rv ||:= l.class||l.ident } write(f,rv,")\n","end") if (__self1 := self).__methods.has_initially(__self1.__state) then { write(f,"procedure ",self.name,"initially(self)") (__self1 := self.text).__methods.write(__self1.__state,f) write(f,"end") } every me := (__self1 := self.fields).__methods.foreachpublic(__self1.__state) do { write(f,"procedure ",self.name,me,"(self)") if \strict then { write(f," if type(self.",me,") == ", "(\"list\"|\"table\"|\"set\"|\"record\") then\n", " runerr(501,\"idol: scalar type expected\")") } write(f," return .(self.",me,")") write(f,"end") write(f) } close(f) endprocedure classresolve(self)#line 513 "idol.iol" self.imethods := [] self.ifields := [] ipublics := [] addedfields := table() addedmethods := table() every sc := (__self1 := self.supers).__methods.foreach(__self1.__state) do { if /(superclass := (__self1 := classes).__methods.lookup(__self1.__state,sc)) then halt("class/resolve: couldn't find superclass ",sc) every superclassfield := (__self1 := superclass).__methods.foreachfield(__self1.__state) do { if /(__self1 := self.fields).__methods.lookup(__self1.__state,superclassfield) & /addedfields[superclassfield] then { addedfields[superclassfield] := superclassfield put ( self.ifields , classident(sc,superclassfield) ) if (__self1 := superclass).__methods.ispublic(__self1.__state,superclassfield) then put( ipublics, classident(sc,superclassfield) ) } else if \strict then { warn("class/resolve: '",sc,"' field '",superclassfield, "' is redeclared in subclass ",self.name) } } every superclassmethod := (__self2 := ((__self1 := superclass).__methods.foreachmethod(__self1.__state))).__methods.name(__self2.__state) do { if /(__self1 := self.methods).__methods.lookup(__self1.__state,superclassmethod) & /addedmethods[superclassmethod] then { addedmethods[superclassmethod] := superclassmethod put ( self.imethods, classident(sc,superclassmethod) ) } } every public := (!ipublics) do { if public.class == sc then put (self.imethods, classident(sc,public.ident)) } } end## globals declared within the class#record classident(class,ident)record class_state(__state,__methods,supers,methods,text,imethods,ifields,glob,name,fields,tag)record class_methods(read,has_initially,ispublic,foreachmethod,foreachsuper,foreachfield,transitive_closure,writedecl,writespec,writemethods,write,resolve,String,name,declaration)global class__oprec, declaration__oprecprocedure class(supers,methods,text,imethods,ifields,glob,name,fields,tag)local self,cloneinitial { if /class__oprec then classinitialize() if /declaration__oprec then declarationinitialize() class__oprec.declaration := declaration__oprec } self := class_state(&null,class__oprec,supers,methods,text,imethods,ifields,glob,name,fields,tag) self.__state := self clone := class_state() clone.__state := clone clone.__methods := class__oprec # inherited initialization from class declaration every i := 2 to *self do clone[i] := self[i] declarationinitially(clone) self.name := clone.name self.fields := clone.fields self.tag := clone.tag return idol_object(self,class__oprec)endprocedure classinitialize() initial class__oprec := class_methods(classread,classhas_initially,classispublic,classforeachmethod,classforeachsuper,classforeachfield,classtransitive_closure,classwritedecl,classwritespec,classwritemethods,classwrite,classresolve,declarationString,declarationname)endprocedure methodread(self,line,phase)#line 556 "idol.iol" (__self1 := self).__methods.declaration.read(__self1.__state,line) self.text := body() if phase = 1 then (__self1 := self.text).__methods.read(__self1.__state) endprocedure methodwritedecl(self,f,s)#line 562 "idol.iol" decl := (__self1 := self).__methods.String(__self1.__state) if s == "method" then decl[1:upto(white,decl)] := "method" else { decl[1:upto(white,decl)] := "procedure" decl[upto(white,decl)] ||:= self.class if *self.class ~= 0 then { i := find("(",decl) decl[i] ||:= "self" || (((decl[i+1] ~== ")"), ",") | "") } } write(f,decl) endprocedure methodwrite(self,f)#line 575 "idol.iol" if self.name ~== "in then (__self1 := self).__methods.writedecl(__self1.__state,f,"procedure") (__self1 := self.text).__methods.write(__self1.__state,f) self.text := &null endrecord method_state(__state,__methods,class,text,name,fields,tag)record method_methods(read,writedecl,write,String,name,declaration)global method__oprec, declaration__oprecprocedure method(class,text,name,fields,tag)local self,cloneinitial { if /method__oprec then methodinitialize() if /declaration__oprec then declarationinitialize() method__oprec.declaration := declaration__oprec } self := method_state(&null,method__oprec,class,text,name,fields,tag) self.__state := self clone := method_state() clone.__state := clone clone.__methods := method__oprec # inherited initialization from class declaration every i := 2 to *self do clone[i] := self[i] declarationinitially(clone) self.name := clone.name self.fields := clone.fields self.tag := clone.tag return idol_object(self,method__oprec)endprocedure methodinitialize() initial method__oprec := method_methods(methodread,methodwritedecl,methodwrite,declarationString,declarationname)endprocedure Globalwrite(self,f)#line 587 "idol.iol" write(f,self.s) endrecord Global_state(__state,__methods,s)record Global_methods(write)global Global__oprecprocedure Global(s)local self,cloneinitial { if /Global__oprec then Globalinitialize() } self := Global_state(&null,Global__oprec,s) self.__state := self return idol_object(self,Global__oprec)endprocedure Globalinitialize() initial Global__oprec := Global_methods(Globalwrite)endprocedure Tablesize(self)#line 596 "idol.iol" return (* \ self.t) | 0 endprocedure Tableinsert(self,x,key)#line 599 "idol.iol" /self.t := table() /key := x if / (self.t[key]) := x then return endprocedure Tablelookup(self,key)#line 604 "idol.iol" if t := \self.t then return t[key] return endprocedure Tableforeach(self)#line 608 "idol.iol" if t := \self.t then every suspend !self.t endrecord Table_state(__state,__methods,t)record Table_methods(size,insert,lookup,foreach)global Table__oprecprocedure Table(t)local self,cloneinitial { if /Table__oprec then Tableinitialize() } self := Table_state(&null,Table__oprec,t) self.__state := self return idol_object(self,Table__oprec)endprocedure Tableinitialize() initial Table__oprec := Table_methods(Tablesize,Tableinsert,Tablelookup,Tableforeach)endprocedure taqueinsert(self,x,key)#line 619 "idol.iol" /self.l := [] if (__self1 := self).__methods.Table.insert(__self1.__state,x,key) then put(self.l,x) endprocedure taqueforeach(self)#line 623 "idol.iol" if l := \self.l then every suspend !self.l endprocedure taqueinsert_t(self,x,key)#line 626 "idol.iol" (__self1 := self).__methods.Table.insert(__self1.__state,x,key) endprocedure taqueforeach_t(self)#line 629 "idol.iol" suspend (__self1 := self).__methods.Table.foreach(__self1.__state) endrecord taque_state(__state,__methods,l,t)record taque_methods(insert,foreach,insert_t,foreach_t,size,lookup,Table)global taque__oprec, Table__oprecprocedure taque(l,t)local self,cloneinitial { if /taque__oprec then taqueinitialize() if /Table__oprec then Tableinitialize() taque__oprec.Table := Table__oprec } self := taque_state(&null,taque__oprec,l,t) self.__state := self return idol_object(self,taque__oprec)endprocedure taqueinitialize() initial taque__oprec := taque_methods(taqueinsert,taqueforeach,taqueinsert_t,taqueforeach_t,Tablesize,Tablelookup)endprocedure idTaqueparse(self,s)#line 639 "idol.iol" s ? { tab(many(white)) while name := tab(find(self.punc)) do { (__self1 := self).__methods.insert(__self1.__state,trim(name)) move(1) tab(many(white)) } if any(nonwhite) then (__self1 := self).__methods.insert(__self1.__state,trim(tab(0))) } return endprocedure idTaqueString(self)#line 651 "idol.iol" if /self.l then return "" out := "" every id := !self.l do out ||:= id||self.punc return out[1:-1] endrecord idTaque_state(__state,__methods,punc,l,t)record idTaque_methods(parse,String,insert,foreach,insert_t,foreach_t,size,lookup,taque,Table)global idTaque__oprec, taque__oprec, Table__oprecprocedure idTaque(punc,l,t)local self,cloneinitial { if /idTaque__oprec then idTaqueinitialize() if /taque__oprec then taqueinitialize() idTaque__oprec.taque := taque__oprec if /Table__oprec then Tableinitialize() idTaque__oprec.Table := Table__oprec } self := idTaque_state(&null,idTaque__oprec,punc,l,t) self.__state := self return idol_object(self,idTaque__oprec)endprocedure idTaqueinitialize() initial idTaque__oprec := idTaque_methods(idTaqueparse,idTaqueString,taqueinsert,taqueforeach,taqueinsert_t,taqueforeach_t,Tablesize,Tablelookup)endprocedure argListinsert(self,s)#line 663 "idol.iol" if \self.varg then halt("variable arg must be final") if i := find("[",s) then { if not (j := find("]",s)) then halt("variable arg expected ]") s[i : j+1] := "" self.varg := s := trim(s) } (__self1 := self).__methods.idTaque.insert(__self1.__state,s) endprocedure argListString(self)#line 672 "idol.iol" return (__self1 := self).__methods.idTaque.String(__self1.__state) || ((\self.varg & "[]") | "") endrecord argList_state(__state,__methods,varg,punc,l,t)record argList_methods(insert,String,varg,parse,foreach,insert_t,foreach_t,size,lookup,idTaque,taque,Table)global argList__oprec, idTaque__oprec, taque__oprec, Table__oprecprocedure argList(varg,punc,l,t)local self,cloneinitial { if /argList__oprec then argListinitialize() if /idTaque__oprec then idTaqueinitialize() argList__oprec.idTaque := idTaque__oprec if /taque__oprec then taqueinitialize() argList__oprec.taque := taque__oprec if /Table__oprec then Tableinitialize() argList__oprec.Table := Table__oprec } self := argList_state(&null,argList__oprec,varg,punc,l,t) self.__state := self argListinitially(self) return idol_object(self,argList__oprec)endprocedure argListinitialize() initial argList__oprec := argList_methods(argListinsert,argListString,argListvarg,idTaqueparse,taqueforeach,taqueinsert_t,taqueforeach_t,Tablesize,Tablelookup)endprocedure argListinitially(self)#line 675 "idol.iol" self.punc := ","endprocedure argListvarg(self) return .(self.varg)endprocedure classFieldsString(self,s)#line 683 "idol.iol" if *(rv := (__self1 := self).__methods.argList.String(__self1.__state)) = 0 then return "" if /s | (s ~== "class") then return rv if (__self1 := self).__methods.ispublic(__self1.__state,self.l[1]) then rv := "public "||rv every field:=(__self1 := self).__methods.foreachpublic(__self1.__state) do rv[find(","||field,rv)] ||:= "public " return rv endprocedure classFieldsforeachpublic(self)#line 690 "idol.iol" if \self.publics then every suspend !self.publics endprocedure classFieldsispublic(self,s)#line 693 "idol.iol" if \self.publics then every suspend !self.publics == s endprocedure classFieldsinsert(self,s)#line 696 "idol.iol" s ? { if ="public" & tab(many(white)) then { s := tab(0) /self.publics := [] put(self.publics,s) } } (__self1 := self).__methods.argList.insert(__self1.__state,s) endrecord classFields_state(__state,__methods,publics,varg,punc,l,t)record classFields_methods(String,foreachpublic,ispublic,insert,varg,parse,foreach,insert_t,foreach_t,size,lookup,argList,idTaque,taque,Table)global classFields__oprec, argList__oprec, idTaque__oprec, taque__oprec, Table__oprecprocedure classFields(publics,varg,punc,l,t)local self,cloneinitial { if /classFields__oprec then classFieldsinitialize() if /argList__oprec then argListinitialize() classFields__oprec.argList := argList__oprec if /idTaque__oprec then idTaqueinitialize() classFields__oprec.idTaque := idTaque__oprec if /taque__oprec then taqueinitialize() classFields__oprec.taque := taque__oprec if /Table__oprec then Tableinitialize() classFields__oprec.Table := Table__oprec } self := classFields_state(&null,classFields__oprec,publics,varg,punc,l,t) self.__state := self classFieldsinitially(self) clone := classFields_state() clone.__state := clone clone.__methods := classFields__oprec # inherited initialization from class argList every i := 2 to *self do clone[i] := self[i] argListinitially(clone) self.varg := clone.varg return idol_object(self,classFields__oprec)endprocedure classFieldsinitialize() initial classFields__oprec := classFields_methods(classFieldsString,classFieldsforeachpublic,classFieldsispublic,classFieldsinsert,argListvarg,idTaqueparse,taqueforeach,taqueinsert_t,taqueforeach_t,Tablesize,Tablelookup)endprocedure classFieldsinitially(self)#line 706 "idol.iol" self.punc := ","end :MPW:MPW Tools:Tools with Source:ICON V8.0:IconDocs-ps Folder:ipd113.ps
%!PS-Adobe-1.0%%Creator: megaron.cs.arizona.edu:ralph (Ralph Griswold)%%Title: stdin (ditroff)%%CreationDate: Tue Mar 6 07:27:10 1990%%EndComments% Start of psdit.pro -- prolog for ditroff translator% Copyright (c) 1985,1987 Adobe Systems Incorporated. All Rights Reserved. % GOVERNMENT END USERS: See Notice file in TranScript library directory% -- probably /usr/lib/ps/Notice% RCS: $Header: psdit.pro,v 2.2 87/11/17 16:40:42 byron Rel $% Psfig RCSID $Header: psdit.pro,v 1.5 88/01/04 17:48:22 trevor Exp $/$DITroff 180 dict def $DITroff begin/DocumentInitState [ matrix currentmatrix currentlinewidth currentlinecapcurrentlinejoin currentdash currentgray currentmiterlimit ] cvx def%% Psfig additions/startFig { /SavedState save def userdict maxlength dict begin currentpoint transform DocumentInitState setmiterlimit setgray setdash setlinejoin setlinecap setlinewidth setmatrix itransform moveto /ury exch def /urx exch def /lly exch def /llx exch def /y exch 72 mul resolution div def /x exch 72 mul resolution div def currentpoint /cy exch def /cx exch def /sx x urx llx sub div def % scaling for x /sy y ury lly sub div def % scaling for y sx sy scale % scale by (sx,sy) cx sx div llx sub cy sy div ury sub translate /DefFigCTM matrix currentmatrix def /initmatrix { DefFigCTM setmatrix } def /defaultmatrix { DefFigCTM exch copy } def /initgraphics { DocumentInitState setmiterlimit setgray setdash setlinejoin setlinecap setlinewidth setmatrix DefFigCTM setmatrix } def /showpage { initgraphics } def} def% Args are llx lly urx ury (in figure coordinates)/clipFig { currentpoint 6 2 roll newpath 4 copy 4 2 roll moveto 6 -1 roll exch lineto exch lineto exch lineto closepath clip newpath moveto} def% doclip, if called, will always be just after a `startfig'/doclip { llx lly urx ury clipFig } def/endFig { end SavedState restore} def/globalstart { % Push details about the enviornment on the stack. fontnum fontsize fontslant fontheight % firstpage mh my resolution slotno currentpoint pagesave restore gsave } def/globalend { grestore moveto /slotno exch def /resolution exch def /my exch def /mh exch def % /firstpage exch def /fontheight exch def /fontslant exch def /fontsize exch def /fontnum exch def F /pagesave save def} def%% end XMOD additions/fontnum 1 def /fontsize 10 def /fontheight 10 def /fontslant 0 def/xi {0 72 11 mul translate 72 resolution div dup neg scale 0 0 moveto /fontnum 1 def /fontsize 10 def /fontheight 10 def /fontslant 0 def F /pagesave save def}def/PB{save /psv exch def currentpoint translate resolution 72 div dup neg scale 0 0 moveto}def/PE{psv restore}def/m1 matrix def /m2 matrix def /m3 matrix def /oldmat matrix def/tan{dup sin exch cos div}bind def/point{resolution 72 div mul}bind def/dround {transform round exch round exch itransform}bind def/xT{/devname exch def}def/xr{/mh exch def /my exch def /resolution exch def}def/xp{}def/xs{docsave restore end}def/xt{}def/xf{/fontname exch def /slotno exch def fontnames slotno get fontname eq not {fonts slotno fontname findfont put fontnames slotno fontname put}if}def/xH{/fontheight exch def F}bind def/xS{/fontslant exch def F}bind def/s{/fontsize exch def /fontheight fontsize def F}bind def/f{/fontnum exch def F}bind def/F{fontheight 0 le {/fontheight fontsize def}if fonts fontnum get fontsize point 0 0 fontheight point neg 0 0 m1 astore fontslant 0 ne{1 0 fontslant tan 1 0 0 m2 astore m3 concatmatrix}if makefont setfont .04 fontsize point mul 0 dround pop setlinewidth}bind def/X{exch currentpoint exch pop moveto show}bind def/N{3 1 roll moveto show}bind def/Y{exch currentpoint pop exch moveto show}bind def/S /show load def/ditpush{}def/ditpop{}def/AX{3 -1 roll currentpoint exch pop moveto 0 exch ashow}bind def/AN{4 2 roll moveto 0 exch ashow}bind def/AY{3 -1 roll currentpoint pop exch moveto 0 exch ashow}bind def/AS{0 exch ashow}bind def/MX{currentpoint exch pop moveto}bind def/MY{currentpoint pop exch moveto}bind def/MXY /moveto load def/cb{pop}def % action on unknown char -- nothing for now/n{}def/w{}def/inch { resolution mul } def % added 7/20/88 aky/cutmark { currentlinewidth 2 setlinewidth % .5 inch .5 inch moveto .5 inch .75 inch lineto stroke % .5 inch .5 inch moveto .75 inch .5 inch lineto stroke % 7.25 inch .5 inch moveto 7.5 inch .5 inch lineto stroke % 7.5 inch .5 inch moveto 7.5 inch .75 inch lineto stroke 0 inch 0 inch moveto 0 inch .25 inch lineto stroke 0 inch 0 inch moveto .25 inch 0 inch lineto stroke 8.25 inch 0 inch moveto 8.5 inch 0 inch lineto stroke 8.5 inch 0 inch moveto 8.5 inch .25 inch lineto stroke setlinewidth }def % added 7/20/88 aky/p{pop cutmark showpage pagesave restore /pagesave save def}def/abspoint{currentpoint exch pop add exch currentpoint pop add exch}def/dstroke{currentpoint stroke moveto}bind def/Dl{2 copy gsave rlineto stroke grestore rmoveto}bind def/arcellipse{oldmat currentmatrix pop currentpoint translate 1 diamv diamh div scale /rad diamh 2 div def rad 0 rad -180 180 arc oldmat setmatrix}def/Dc{gsave dup /diamv exch def /diamh exch def arcellipse dstroke grestore diamh 0 rmoveto}def/De{gsave /diamv exch def /diamh exch def arcellipse dstroke grestore diamh 0 rmoveto}def/Da{currentpoint /by exch def /bx exch def /fy exch def /fx exch def /cy exch def /cx exch def /rad cx cx mul cy cy mul add sqrt def /ang1 cy neg cx neg atan def /ang2 fy fx atan def cx bx add cy by add 2 copy rad ang1 ang2 arcn stroke exch fx add exch fy add moveto}def/Barray 200 array def % 200 values in a wiggle/D~{mark}def/D~~{counttomark Barray exch 0 exch getinterval astore /Bcontrol exch def pop /Blen Bcontrol length def Blen 4 ge Blen 2 mod 0 eq and {Bcontrol 0 get Bcontrol 1 get abspoint /Ycont exch def /Xcont exch def Bcontrol 0 2 copy get 2 mul put Bcontrol 1 2 copy get 2 mul put Bcontrol Blen 2 sub 2 copy get 2 mul put Bcontrol Blen 1 sub 2 copy get 2 mul put /Ybi /Xbi currentpoint 3 1 roll def def 0 2 Blen 4 sub {/i exch def Bcontrol i get 3 div Bcontrol i 1 add get 3 div Bcontrol i get 3 mul Bcontrol i 2 add get add 6 div Bcontrol i 1 add get 3 mul Bcontrol i 3 add get add 6 div /Xbi Xcont Bcontrol i 2 add get 2 div add def /Ybi Ycont Bcontrol i 3 add get 2 div add def /Xcont Xcont Bcontrol i 2 add get add def /Ycont Ycont Bcontrol i 3 add get add def Xbi currentpoint pop sub Ybi currentpoint exch pop sub rcurveto }for dstroke}if}defend/ditstart{$DITroff begin /nfonts 60 def % NFONTS makedev/ditroff dependent! /fonts[nfonts{0}repeat]def /fontnames[nfonts{()}repeat]def/docsave save def}def% character outcalls/oc {/pswid exch def /cc exch def /name exch def /ditwid pswid fontsize mul resolution mul 72000 div def /ditsiz fontsize resolution mul 72 div def ocprocs name known{ocprocs name get exec}{name cb} ifelse}def/fractm [.65 0 0 .6 0 0] def/fraction {/fden exch def /fnum exch def gsave /cf currentfont def cf fractm makefont setfont 0 .3 dm 2 copy neg rmoveto fnum show rmoveto currentfont cf setfont(\244)show setfont fden show grestore ditwid 0 rmoveto} def/oce {grestore ditwid 0 rmoveto}def/dm {ditsiz mul}def/ocprocs 50 dict def ocprocs begin(14){(1)(4)fraction}def(12){(1)(2)fraction}def(34){(3)(4)fraction}def(13){(1)(3)fraction}def(23){(2)(3)fraction}def(18){(1)(8)fraction}def(38){(3)(8)fraction}def(58){(5)(8)fraction}def(78){(7)(8)fraction}def(sr){gsave .05 dm .16 dm rmoveto(\326)show oce}def(is){gsave 0 .15 dm rmoveto(\362)show oce}def(->){gsave 0 .02 dm rmoveto(\256)show oce}def(<-){gsave 0 .02 dm rmoveto(\254)show oce}def(==){gsave 0 .05 dm rmoveto(\272)show oce}defend% DIThacks fonts for some special chars50 dict dup begin/FontType 3 def/FontName /DIThacks def/FontMatrix [.001 0.0 0.0 .001 0.0 0.0] def/FontBBox [-220 -280 900 900] def% a lie but .../Encoding 256 array def0 1 255{Encoding exch /.notdef put}forEncoding dup 8#040/space put %space dup 8#110/rc put %right ceil dup 8#111/lt put %left top curl dup 8#112/bv put %bold vert dup 8#113/lk put %left mid curl dup 8#114/lb put %left bot curl dup 8#115/rt put %right top curl dup 8#116/rk put %right mid curl dup 8#117/rb put %right bot curl dup 8#120/rf put %right floor dup 8#121/lf put %left floor dup 8#122/lc put %left ceil dup 8#140/sq put %square dup 8#141/bx put %box dup 8#142/ci put %circle dup 8#143/br put %box rule dup 8#144/rn put %root extender dup 8#145/vr put %vertical rule dup 8#146/ob put %outline bullet dup 8#147/bu put %bullet dup 8#150/ru put %rule dup 8#151/ul put %underline pop/DITfd 100 dict def/BuildChar{0 begin /cc exch def /fd exch def /charname fd /Encoding get cc get def /charwid fd /Metrics get charname get def /charproc fd /CharProcs get charname get def charwid 0 fd /FontBBox get aload pop setcachedevice 40 setlinewidth newpath 0 0 moveto gsave charproc grestore end}def/BuildChar load 0 DITfd put%/UniqueID 5 def/CharProcs 50 dict defCharProcs begin/space{}def/.notdef{}def/ru{500 0 rls}def/rn{0 750 moveto 500 0 rls}def/vr{20 800 moveto 0 -770 rls}def/bv{20 800 moveto 0 -1000 rls}def/br{20 770 moveto 0 -1040 rls}def/ul{0 -250 moveto 500 0 rls}def/ob{200 250 rmoveto currentpoint newpath 200 0 360 arc closepath stroke}def/bu{200 250 rmoveto currentpoint newpath 200 0 360 arc closepath fill}def/sq{80 0 rmoveto currentpoint dround newpath moveto 640 0 rlineto 0 640 rlineto -640 0 rlineto closepath stroke}def/bx{80 0 rmoveto currentpoint dround newpath moveto 640 0 rlineto 0 640 rlineto -640 0 rlineto closepath fill}def/ci{355 333 rmoveto currentpoint newpath 333 0 360 arc 50 setlinewidth stroke}def/lt{20 -200 moveto 0 550 rlineto currx 800 2cx s4 add exch s4 a4p stroke}def/lb{20 800 moveto 0 -550 rlineto currx -200 2cx s4 add exch s4 a4p stroke}def/rt{20 -200 moveto 0 550 rlineto currx 800 2cx s4 sub exch s4 a4p stroke}def/rb{20 800 moveto 0 -500 rlineto currx -200 2cx s4 sub exch s4 a4p stroke}def/lk{20 800 moveto 20 300 -280 300 s4 arcto pop pop 1000 sub currentpoint stroke moveto 20 300 4 2 roll s4 a4p 20 -200 lineto stroke}def/rk{20 800 moveto 20 300 320 300 s4 arcto pop pop 1000 sub currentpoint stroke moveto 20 300 4 2 roll s4 a4p 20 -200 lineto stroke}def/lf{20 800 moveto 0 -1000 rlineto s4 0 rls}def/rf{20 800 moveto 0 -1000 rlineto s4 neg 0 rls}def/lc{20 -200 moveto 0 1000 rlineto s4 0 rls}def/rc{20 -200 moveto 0 1000 rlineto s4 neg 0 rls}defend/Metrics 50 dict def Metrics begin/.notdef 0 def/space 500 def/ru 500 def/br 0 def/lt 250 def/lb 250 def/rt 250 def/rb 250 def/lk 250 def/rk 250 def/rc 250 def/lc 250 def/rf 250 def/lf 250 def/bv 250 def/ob 350 def/bu 350 def/ci 750 def/bx 750 def/sq 750 def/rn 500 def/ul 500 def/vr 0 defendDITfd begin/s2 500 def /s4 250 def /s3 333 def/a4p{arcto pop pop pop pop}def/2cx{2 copy exch}def/rls{rlineto stroke}def/currx{currentpoint pop}def/dround{transform round exch round exch itransform} defendend/DIThacks exch definefont popditstart(psc)xT576 1 1 xr1(Times-Roman)xf 1 f2(Times-Italic)xf 2 f3(Times-Bold)xf 3 f4(Times-BoldItalic)xf 4 f5(Helvetica)xf 5 f6(Helvetica-Bold)xf 6 f7(Courier)xf 7 f8(Courier-Bold)xf 8 f9(Symbol)xf 9 f10(DIThacks)xf 10 f10 s1 fxi%%EndProlog%%Page: 1 110 s 10 xH 0 xS 1 f3 f1836 672(The)N1989(Icon)X2160(Memory)X2475(Monitoring)X2886(System)X1 f2151 864(Gregg)N2372(M.)X2483(Townsend)X1501 1008(Department)N1900(of)X1987(Computer)X2327(Science,)X2617(The)X2762(University)X3120(of)X3207(Arizona)X3 f612 1392(Introduction)N1 f732 1516(The)N880(Icon)X1047(memory)X1338(monitoring)X1717(system)X1963(\(``MemMon''\))X2469(provides)X2769(tools)X2948(for)X3066(displaying)X3423(Icon's)X3648(allocated)X3962(data)X4120(regions)X612 1612([1].)N775(It)X853(consists)X1135(of)X1231(instrumentation)X1762(that)X1911(produces)X2 f2230(allocation)X2583(history)X2834(\256les)X1 f2992(\(Appendix)X3364(C\))X3472(and)X3616(visualization)X4053(programs)X612 1708(that)N758(convert)X1025(allocation)X1367(history)X1615(\256les)X1774(to)X1862(displays)X2150(that)X2296(show)X2491(the)X2615(sizes,)X2817(types,)X3032(and)X3174(locations)X3490(of)X3584(strings)X3824(as)X3918(they)X4083(are)X4209(allo-)X612 1804(cated.)N842(The)X987(garbage)X1262(collection)X1598(process)X1859(is)X1932(shown)X2161(in)X2243(detail.)X732 1928(There)N946(are)X1071(several)X1325(visualization)X1760(programs;)X2111(most)X2293(of)X2387(them)X2574(are)X2700(speci\256c)X2972(to)X3061(the)X3186(University)X3551(of)X3645(Arizona)X3931(environment.)X612 2024(Appendix)N948(A)X1026(describes)X3 f1345(mmps)X1 f1554(,)X1594(a)X1650(program)X1942(for)X2056(producing)X2401(displays)X2683(that)X2823(can)X2955(be)X3051(printed)X3298(on)X3398(any)X3534(PostScript)X3882(printer.)X732 2148(An)N851(allocation)X1188(history)X1432(\256le)X1556(is)X1631(produced)X1952(by)X2054(setting)X2289(the)X2409(environment)X2836(variable)X5 f3119(MEMMON)X1 f3515(to)X3599(the)X3719(name)X3915(of)X4004(the)X4124(desired)X612 2244(\256le.)N782(No)X907(change)X1162(in)X1251(the)X1376(Icon)X1546(program)X1845(is)X1925(necessary)X2265(and)X2408(the)X2533(production)X2907(of)X3001(an)X3104(allocation)X3447(history)X3696(\256le)X3825(does)X3999(not)X4128(change)X612 2340(program)N915(behavior)X1227(\(except)X1495(for)X1620(increasing)X1981(run)X2119(time)X2292(somewhat\).)X2715(On)X2844(Unix)X3035(systems,)X3339(if)X3419(the)X3548(value)X3753(of)X3851(the)X5 f3982(MEMMON)X1 f612 2436(environment)N1039(variable)X1320(begins)X1550(with)X1713(`)X5 f9 f1740(|)X1 f(',)S1824(the)X1943(rest)X2080(of)X2168(the)X2287(value)X2482(is)X2556(interpreted)X2925(as)X3013(a)X3070(shell)X3242(command)X3579(into)X3724(which)X3941(the)X4060(history)X4303(is)X612 2532(piped.)N3 f612 2724(The)N765(Display)X1 f732 2848(Icon)N900(has)X1032(two)X1177(primary)X1456(allocated)X1771(data)X1930(regions:)X2213(a)X2274(string)X2481(region)X2711(and)X2852(a)X2914(block)X3118(region.)X3389(On)X3513(implementations)X4072(that)X4218(sup-)X612 2944(port)N768(region)X1000(expansion)X1352([2],)X1493(there)X1681(is)X1761(also)X1917(a)X1980(static)X2176(region.)X2448(The)X2600(display)X2858(shows)X3084(the)X3208(regions)X3470(as)X3563(if)X3638(they)X3802(were)X3985(contiguous,)X612 3040(which)N836(they)X1002(are)X1129(on)X1237(implementations)X1799(that)X1948(support)X2217(region)X2451(expansion.)X2845(The)X2999(static)X3197(region,)X3451(if)X3529(it)X3602(exists,)X3833(comes)X4067(\256rst,)X4240(fol-)X612 3136(lowed)N835(by)X942(the)X1067(string)X1276(and)X1419(block)X1624(regions.)X1927(The)X2079(choice)X2316(of)X2410(regions)X2673(that)X2820(are)X2946(displayed)X3279(can)X3417(be)X3519(speci\256ed.)X3870(By)X3989(default,)X4258(the)X612 3232(static)N801(region)X1026(is)X1099(not)X1221(displayed,)X1568(but)X1690(the)X1808(string)X2010(and)X2146(block)X2344(regions)X2600(are.)X732 3356(Color)N936(distinguishes)X1375(the)X1495(various)X1754(uses)X1915(of)X2005(memory,)X2315(and)X2454(by)X2557(inference)X2880(the)X3001(region)X3229(boundaries.)X3644(A)X3725(legend)X3962(at)X4043(the)X4164(top)X4289(of)X612 3452(the)N736(screen)X968(gives)X1163(the)X1287(meaning)X1589(of)X1682(each)X1856(color.)X2087(Default)X2354(colors)X2576(can)X2713(be)X2814(changed)X3107(by)X3212(providing)X3548(an)X3649(alternate)X3951(speci\256cation)X612 3548(\256le.)N732 3672(Colors)N972(and)X1115(boundaries)X1494(are)X1620(set)X1736(at)X1821(allocation)X2164(t
++++++++ Continued on next card ++++++++
:MPW:MPW Tools:Tools with Source:ICON V8.0:IconDocs-ps Folder:ipd113.p
